Merge specific cells from columns from multiple files to one sheet - vba

Question

I am trying to merge data from particular columns from multiple csv files. This thread: Excel VBA - Merge specific columns from multiple files to one sheet worked for whole ranges of columns. However, I want to copy e.g. each 100th cell from particular column (instead of whole column as it is at the moment).
I have tried to modify the code as per below method 1 and 2 (see **** notes).
This VBA is to go through datalog files which have time stamps in rows and parameters for each time stamp. However, I don't want all parameters, only selected ones (per columns) and in each 100th row.
'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
1st method (when working) results in shift of rows from next columns (all pasted data start from last row (not last row in particular column), it more less results in below pattern (where cl is for column and x represents data):
cl1 cl2 cl3 cl3
x
x
x
x
x
x
x
x
x x
x
x
x
x
x
While I want to receive below pattern:
cl1 cl2 cl3 cl3
x x x x
x x x x
x x x x
Another question is how should I modify function: LastRowUsed not to start from A1, but e.g. from B1, etc.? I tried to resolve that with Method 2.

Answer 1

Based on feedback above I have changed the loops order and that made it work. I have also polished the code (copying from range to range and added option explicit). Code does the job now.
Now I will be trying to change it to more efficient version (it takes plenty of time with few hundreds of workbooks). At the moment I am copying and pasting each cell individually between workbooks. I think that a set of cells (e.g. multiple selection of each 100th cell) would be quicker.
Or building an array of values needed and pasting array into headingsWorkbook as range.
Here is how the code looks now:
Option Explicit
'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 RFSSearchThenCombineEach1000thRow()
'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 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 j = 2 To LRowOpenedBook Step 1000
LRowHeading = LRowHeading + 1 'move one row down in HeadingWorkbook, each 1000 rows of openedworkbook
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
OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
OpenedWorkSheet.Cells(j, i)).Copy _
HeadingWorkSheet.Range(HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)), _
HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)))
End If
Next i
Next j
openedWorkBook.Close (False)
Next ' move on to next file
End Sub