| |
まずこれを見てください
Sub 目録貼り付け()
'コピーしたものを貼り付けるファイルを開く
Dim Fname As String
Fname = Application.GetOpenFilename(filefilter:="Excelファイル,*.xls,すべてのファイル,*.*")
If Fname = "false" Then
Exit Sub
End If
Workbooks.Open Filename:=Fname
'コピー元があるファイルを開く
Fname2 = Application.GetOpenFilename(filefilter:="Excelファイル,*.xls,すべてのファイル,*.*")
If Fname2 = "false" Then
Exit Sub
End If
Workbooks.Open Filename:=Fname2
'コピー元のファイルのシート名に「目録」が含まれるシートを選択
Dim ws As Worksheet
For Each ws In Worksheets
If InStr(ws.Name, "目録") <> 0 Then
ws.Activate
ActiveSheet.Range("A1").Activate
'コピー元の選択したシートのAセルの値を上から順に読み取る(条件つけて)
Dim R As Range
Dim MyR As Range
Set MyR = Range("A1", Range("A65536").End(xlUp))
For Each R In MyR
'If1 結合あり
If Selection.MergeCells Then
'○ひとつしたのセルへ
Selection.Offset(1, 0).Select
Selection.Offset(0, 2).Select
'ElseIf1 結合なし
ElseIf Not Selection.MergeCells Then
'If2 空セル
If Selection.Value = "" Then
'○ひとつしたのセルへ
Selection.Offset(1, 0).Select
'ElseIf2 空セルでない
ElseIf Selection.Value <> "" Then
'If22 セルの文字数が4文字以下
If 4 >= Len(Selection.Value) Then
'○ひとつしたのセルへ
Selection.Offset(1, 0).Select
'If22 セルの文字数が4文字よりうえ
ElseIf 4 < Len(Selection.Value) Then
'条件にあったセルの値を最初に開いていたファイルのシート1のAセルに上から順に貼り付ける
Dim j As Long
j = 1: On Error GoTo ELine
Selection.Copy Workbooks("test.xls").Worksheets("Sheet1") _
.Cells(j, 1)
j = j + 1
ELine:
If Err.Number <> 0 Then MsgBox Err.Description
'End22 If
End If
'End2 If
End If
'End1 If
End If
Next R
End If
Next ws
ActiveWorkbook.Close
End Sub
現在このような感じで作成しているのですが、
コピーしたものを、別に開いてあるブックに
上から順に貼り付けることが出来ません。
違うところは多々あるとは思いますが、
出来れば、ヒントなりをお教えねがいませんでしょうか？
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
