| |
▼だいすけ さん：
>>２、なにをコピーしたいのでしょうか？ 空白以外 and 4文字以上？
>コピーしたい内容は、Aセルにある値のうち空白以外で、4文字以上の物
>のみです。
よく考えたら空白のセルは4文字以下ですね＾＾
Sub 目録貼り付け()
Dim Fname As String
Dim wb, Addwb As Workbook
Dim ws As Worksheet
Dim R As Range
Dim wb_r As Long
'コピーしたものを貼り付けるファイルを開く
Fname = Application.GetOpenFilename(filefilter:="Excelファイル,*.xls,すべてのファイル,*.*")
If Fname = "False" Then Exit Sub
Set wb = Workbooks.Open(Fname)
'コピー元があるファイルを開く
Fname = Application.GetOpenFilename(filefilter:="Excelファイル,*.xls,すべてのファイル,*.*")
If Fname = "False" Then Set wb = Nothing: Exit Sub
Set Addwb = Workbooks.Open(Fname)
wb_r = wb.Worksheets(1).Range("A1").Range("A65536").End(xlUp).Row
If wb_r <> 1 Then wb_r = wb_r + 1
'コピー元のファイルのシート名に「目録」が含まれるシートを選択
For Each ws In Addwb.Worksheets
If InStr(1, ws.Name, "目録") <> 0 Then
For Each R In Range(ws.Range("A1"), ws.Range("A1").Range("A65536").End(xlUp))
If R.MergeCells = False And Len(R.Value) >= 4 Then
wb.Worksheets(1).Cells(wb_r, 1).Value = R.Value
wb_r = wb_r + 1
End If
Next R
End If
Next ws
'コピー元のファイルを閉じる？
Addwb.Close
Set wb = Nothing
Set Addwb = Nothing
End Sub
|
|
ハチ
- 06/5/24(水) 13:26 -
