Ted Penner
asked on
Fix insertion and shifting issue
I had this question after viewing this Debug combiner.
The code below for the attached macro and test files seem to move all data over two columns, thus ignoring the first two columns all together.
The macro should continue to be agnostic. It should not matter what columns are there, and the only column that should be inserted if it does not already exist is the first one which should be called "Filename".
Assistance in fixing this is greatly appreciated.160401-File-Row-Combiner.xlsbFileA.xlsxFileB.xlsx
FUNCTION:
MAIN CODE:
The code below for the attached macro and test files seem to move all data over two columns, thus ignoring the first two columns all together.
The macro should continue to be agnostic. It should not matter what columns are there, and the only column that should be inserted if it does not already exist is the first one which should be called "Filename".
Assistance in fixing this is greatly appreciated.160401-File-Row-Combiner.xlsbFileA.xlsxFileB.xlsx
FUNCTION:
Option Explicit
Public Function UseFolderDialogOpen() As String
Dim lngCount As Long
' Open the folder dialog
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
' Set Current Folder Path
For lngCount = 1 To .SelectedItems.Count
UseFolderDialogOpen = .SelectedItems(lngCount)
Next lngCount
End With
End Function
MAIN CODE:
Option Explicit
Sub simpleXlsMerger()
Dim wsTable As Worksheet, ws As Worksheet
Dim rRng As Range
Dim bookList As Workbook
Dim path As String, MyName As String
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Dim rToCopy As Range, rNextCl As Range
Dim bHeaders As Boolean
Dim fRow As Long, lRow As Long
Set ws = ActiveSheet
Set mergeObj = CreateObject("Scripting.FileSystemObject")
'change folder path of excel files here
path = UseFolderDialogOpen
If path = "" Then Exit Sub
Set dirObj = mergeObj.Getfolder(path)
Set filesObj = dirObj.Files
On Error GoTo exit_Proc
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
'Grab filename from each open file
MyName = everyObj.Name
With ws
Set rRng = .Range("A1").CurrentRegion
If rRng.Cells.Count = 0 Then
'no data in master sheet
bHeaders = False
Else: bHeaders = True
End If
If Not bHeaders Then
Set rNextCl = .Cells(1, 2)
bHeaders = True
Else: Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 2)
'headers exist so don't copy
End If
End With
With ActiveSheet
If bHeaders Then
Set rToCopy = .Range("A1").CurrentRegion.Offset(1)
Else: Set rToCopy = .Range("A1").CurrentRegion
End If
rToCopy.Copy rNextCl.Offset(, 1)
lRow = ws.Cells(1, 1).CurrentRegion.Rows.Count
'Paste site name to column A
ws.Range("A" & rNextCl.Row & ":" & "A" & lRow).Value = Left(MyName, Len(MyName) - 5)
End With
bookList.Close False
Next
exit_Proc:
' With wsTable
' 'make all cells same height
' .Rows.RowHeight = 15
'
' 'convert sheet2 into table
' Set rRng = .Range("A1").CurrentRegion
' ' If rRng.ListObject.Name <> "" Then
' ' MsgBox "Table already exists", vbCritical, "Abort"
' ' Exit Sub
' ' Else: .ListObjects.Add(xlSrcRange, rRng, , xlYes).Name = "MyTable"
' ' End If
' End With
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
That works, but does not create the first column for the Filename, or check to see if column Filename already exists.
ASKER
Pleased to help, I'll post code to amend what you want later
I thought you wanted the file name in the first column. This line was in your original code
Open in new window