0
複数のcsvファイルの特定の列のデータをマージしようとしています。このスレッド：Excel VBA - Merge specific columns from multiple files to one sheetは全列範囲で機能しました。しかし、私はコピーしたい。特定の列の各100番目のセル（現時点では列全体ではなく）。複数のファイルの列の特定のセルを1つのシートにマージする
以下の方法1と2（****の注を参照）に従ってコードを修正しようとしました。
このVBAは、各タイムスタンプの行とパラメータにタイムスタンプを持つデータログファイルを経由します。しかし、私はすべてのパラメータを必要とせず、選択されたもの（列ごと）と各100行目にのみ必要です。
'takes worksheet and returns last row
Private Function LastRowUsed(sh As Worksheet) As Long
On Error Resume Next
LastRowUsed = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'takes worksheet and returns last column
Private Function LastColUsed(sh As Worksheet) As Long
On Error Resume Next
LastColUsed = sh.Cells.Find(What:="*", _
After:=sh.Range(A1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
'takes worksheet and returns last row in column
Private Function LastRowUsedbyCol(sh As Worksheet, ByVal Col As String) As Long
On Error Resume Next
LastRowUsed = sh.Cells.Find(What:="*", _
After:=sh.Range(Cell(Col, 1), Cell(Col, 1)), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function GetFileListArray() As String()
Dim fileDialogBox As FileDialog
Dim SelectedFolder As Variant
Dim MYPATH As String
Dim MYFILES() As String
Dim FILESINPATH
Dim FNUM, i As Integer
'''''
Set fileDialogBox = Application.FileDialog(msoFileDialogFolderPicker)
'Use a With...End With block to reference the FileDialog object.
With fileDialogBox
If .Show = -1 Then 'the user chose a folder
For Each SelectedFolder In .SelectedItems
MYPATH = SelectedFolder 'asign mypath to the selected folder name
'MsgBox "The path is:" & SelectedFolder, vbInformation 'display folder selected
Next SelectedFolder
'The user pressed Cancel.
Else
MsgBox "Cancel was pressed or Invalid folder chosen, ending macro"
Exit Function
End If
End With
'Set the file dialog object variable to Nothing to clear memory
Set fileDialogBox = Nothing
If Right(MYPATH, 1) <> "\" Then
MYPATH = MYPATH & "\"
End If
FILESINPATH = Dir(MYPATH & "*.csv")
'MsgBox FILESINPATH
If FILESINPATH = "" Then
MsgBox "No files found"
Exit Function
End If
'Fill the array(myFiles)with the list of Excel files in the folder
FNUM = 0
Do While FILESINPATH <> ""
FNUM = FNUM + 1
ReDim Preserve MYFILES(1 To FNUM)
MYFILES(FNUM) = MYPATH & FILESINPATH
FILESINPATH = Dir()
Loop
GetFileListArray = MYFILES()
End Function
Sub RFSSearchThenCombine()
'search first worksheet in files opened, change to search other worksheets
Const SHEET_TO_SEARCH = 1
Dim FileList() As String
Dim CurrentFolder As String
Dim openedWorkBook As Workbook, HeadingWorkbook As Workbook
Dim OpenedWorkSheet As Worksheet, HeadingWorkSheet As Worksheet
Dim i, counter, x, j As Integer
Dim LRowHeading, LRowOpenedBook, LColHeading, LColOpenedBook, LRowHeadingC As Long
Dim dict As dictionary
Dim searchValue
'set original workbook with headings to retrieve
Set HeadingWorkbook = ActiveWorkbook
Set HeadingWorkSheet = HeadingWorkbook.Sheets(1)
'find last column on heading worksheet
LColHeading = LastColUsed(HeadingWorkSheet)
'create dictionary to link headers to position in heading worksheet
Set dict = CreateObject("Scripting.Dictionary")
For x = 1 To LColHeading
dict.Add HeadingWorkSheet.Cells(1, x).Value, x
Next x
FileList() = GetFileListArray()
For counter = 1 To UBound(FileList)
Set openedWorkBook = Workbooks.Open(FileList(counter))
Set OpenedWorkSheet = openedWorkBook.Sheets(SHEET_TO_SEARCH)
LColOpenedBook = LastColUsed(openedWorkBook.Sheets(1))
LRowOpenedBook = LastRowUsed(openedWorkBook.Sheets(1))
LRowHeading = LastRowUsed(HeadingWorkSheet)
For i = 1 To LColOpenedBook 'search headers from a1 to last header
searchValue = OpenedWorkSheet.Cells(1, i).Value 'set search value in to current header
If dict.Exists(searchValue) Then
' *** code from previous thread
'OpenedWorkSheet.Range(OpenedWorkSheet.Cells(1, i), _
'OpenedWorkSheet.Cells(LRowOpenedBook, i)).Copy _
'(HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)))
'**** my proposal
For j = 1 To LRowOpenedBook Step 100
OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
OpenedWorkSheet.Cells(j, i)).Copy _
(HeadingWorkSheet.Cells(LRowHeading + 1, dict.Item(searchValue)))
LRowHeading = LRowHeading + 1
'**** my 2nd proposal
'LRowHeadingC = HeadingWorkSheet.Cells(Rows.Count, i).End(xlUp).Row
'For j = 1 To LRowOpenedBook Step 100
' OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
'OpenedWorkSheet.Cells(j, i)).Copy _
'(HeadingWorkSheet.Cells(LRowHeadingC + 1, dict.Item(searchValue)))
'LRowHeadingC = LRowHeadingC + 1
Next j
End If
Next i
openedWorkBook.Close (False)
Next counter ' move on to next file
End Sub
1方法CLをするためのものである場合、次の列（すべて貼り付けデータが最後の行から開始する（特定の列ではない最後の行）以下のパターンで、それより少ない結果（の行のシフト結果を（作業）列とXのデータを表します）：
cl1 cl2 cl3 cl3
x
x
x
x
x
x
x
x
x x
x
x
x
x
x
私はパターンの下に受信したいものの：
cl1 cl2 cl3 cl3
x x x x
x x x x
x x x x
もう一つの問題は、どのように私は機能を変更する必要があります：A1から開始しないLastRowUsedが、電子.g。 B1などから？私は方法2でそれを解決しようとしました。
どのように '...ステップは100'動作しませんしませんでしたか？エラーがありますか、情報が欠落していますか/情報をスキップしていますか？ – BruceWayne
基本的に、HeadingWorkSheetにデータが貼り付けられていません – kamusial
'dict.Item（searchValue）'は数値を返しますか？また、範囲をコピーしていますので、セルに範囲を貼り付けるのではなく、範囲に貼り付けて、それが役立つかどうか確認してください。 – BruceWayne