Hello all! I posted a thread recently about consolidation and have gotten it close to where I want it, but am still having trouble with regard to one aspect. I am trying to fix up the part about the NextEmptyColumn. I would like for every new "FilesInPath" that the copied cells be added two columns to the right. So if the first file gets copied and pasted into columns B&C, I want the next file to get copied into D&E, and the next to be in F&G, etc. I cannot think of a way to increment the paste column by two each time, can any of you think of a way to do this?
Please only focus on the bolded part. The rest of the macro is working fine. I would appreciate any help on this. Thank you very much!
Please only focus on the bolded part. The rest of the macro is working fine. I would appreciate any help on this. Thank you very much!
Code:
Option Explicit
Sub CombineFiles()
Dim FolderPath As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Dim FolderPicker As Object
Dim FilesInPath As String
Dim LastRow As Long
Dim NextEmptyColumn As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim intChoice As Integer
Set FolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
FolderPicker.AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = FolderPicker.Show
'determine what choice the user made
If intChoice <> 0 Then
'get the folder path selected by the user
FolderPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else: End
End If
' Add a slash at the end of the path if needed.
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(FolderPath & "*.xls*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
[B] Do While FilesInPath <> ""
Set Wkb = Workbooks.Open(FolderPath & FilesInPath)
For Each WS In Wkb.Worksheets
WS.Cells.UnMerge
NextEmptyColumn = Cells(1, Columns.Count).End(xlToLeft).Column
If WS.Name <> "Features" Then
LastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
ActiveWorkbook.Worksheets(WS.Name).Range("B1:C" & LastRow).Copy
ThisWorkbook.Worksheets(WS.Name).Cells(1, NextEmptyColumn).PasteSpecial (xlPasteAll)
Else
LastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
ActiveWorkbook.Worksheets(WS.Name).Range("C1:D" & LastRow).Copy
ThisWorkbook.Worksheets(WS.Name).Cells(1, NextEmptyColumn).PasteSpecial (xlPasteAll)
End If
Next WS
Wkb.Close False
FilesInPath = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True[/B]
End Sub
