わかりました。もっと多くの反応を得るために、これを修正する必要があるかもしれません 。)
以下のコードは正常に動作し、次のことを行います。
列Bに示されている必要なデータを検索します(列Cはオフセット番号によるコピー先です)
これにより、セル B12:B23 内のすべての情報が取得され、次のデータに転送されます。
次に、この情報を次のシートに貼り付けます。
これまでのところすべて順調です。ここで必要なのは、ソース データの列 D、F、H、J、および L の残りの情報を検索し、上記のデータの下にある後続の行に貼り付けることです。
Private Sub MultipleItemExtract(strFileName As String, rngItem As Range, rngDataWrite As Range)
' Copies all data in specified cell addresses of specified worksheets
' of strFileName to specified columns of row rngDataWrite in active sheet.
'
' parameters: strFileName - data type String - name of file to search in
' rngDataWrite - data type Range - write location
' rngWSandItems - data type Range - worksheet and items location
' rngColumn - data type Range - destination column location
'
' notes for external parameters (in "Parameters" worksheet):
' Data from separate worksheets to be exactly one line apart
' Data from within the same worksheet to be zero lines apart
' Do not insert columns between the "Item", "Address" and "Destination" columns
Dim strCurrentWorksheet As String
While rngItem <> ""
'set current worksheet
strCurrentWorksheet = rngItem
'move to items
Set rngItem = rngItem.Offset(1, 0)
With Workbooks(strFileName).Worksheets(strCurrentWorksheet)
While rngItem <> ""
Cells(rngDataWrite.row, rngItem.Offset(0, 2)) = .Range(rngItem.Offset(0, 1).Value)
Set rngItem = rngItem.Offset(1, 0)
Wend
End With
'skip the space between worksheets
Set rngItem = rngItem.Offset(1, 0)
Wend
End Sub
必要に応じてこちらのチャット機能に参加して話し合いをしたいと思っています。本当にこれを解決する必要があり、皆様のご意見に感謝しています。
皆さん、ありがとうございました!マット