View Full Version : [SOLVED:] Need to combined 87 xlsx worksheets into 1 & append source filename to each record
I have 87 xlsx worksheets that I need to combined into 1. The caveat is that I need to add the source worksheet name to each record. Each worksheet contains a header and not all cells are populated in the 87 worksheets.
The data is populated in columns A through J on all worksheets, however, some cells are not populated.
I have tried using KB #151 and KB # 221 just to combine, but it did not work. In reviewing the code for the KB code, all files are referred to as xls and not xlsx. I'm not sure if that is why it didn't work. However, I do need the source worksheet name added to the records in column "K", so it is a moot point.
Attached is a sample of the first 200 records from each of the first 3 files combined with the source filename appended in column "K". Sure hope someone can help me out with this.
Bob Phillips
01-19-2014, 10:55 AM
Public Sub MergeFiles()
Dim this As Worksheet
Dim lastrow As Long
Dim nextrow As Long
Dim i As Long
Set this = ActiveSheet
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.InitialFileName = "*.xls*"
If .Show = -1 Then
this.Range("A1:K1").Value = Array("FIRSTNAME", "LASTNAME", "ADDRESSLINE1", "ADDRESSLINE2", _
"CITY", "STATE", "ZIPCODE", "AGEOFINDIVIDUAL", _
"ESTINCOME", "ORDER", "Sourcefile")
nextrow = 2
For i = 1 To .SelectedItems.Count
Workbooks(i).Open
lastrow = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
ActiveWorkbook.Worksheets(1).Range("A2").Resize(lastrow - 1, 10).Copy this.Cells(nextrow, "A")
this.Cells(nextrow, "K").Resize(lastrow - 1).Value = Activeworkbook.Name
ActiveWorkbook.Close savechanges:=False
nextrow = nextrow + lastrow - 1
Next i
End If
End With
End Sub
Howdy from Arizona Pam,
I see that you joined in August, but that this is only your second post, so a belated welcome to vbaexpress:wavey:
I have 87 xlsx worksheets that I need to combined into 1. The caveat is that I need to add the source worksheet name to each record. Each worksheet contains a header and not all cells are populated in the 87 worksheets.
Okay, what I think we need to know are some "rules" or things we can count on. Are the 87 workbooks all in one folder, or???
Is it only one worksheet per workbook that we need to rip data from?
If so, is it (a) always the first sheet in the workbook, or (b) always a sheet named nnnn?
The data is populated in columns A through J on all worksheets, however, some cells are not populated.
I don't think that should give us any issue, but am curious. In your attached output example, there are numbers stored as text and dates stored as text. (Yuck.) Is that true in the source workbooks?
And just because it caught my eye, why is there no extension showing for 'CHN DEC10 FINAL PENDED LIST'?
Mark
To your first question; yes, all workbooks are in one folder.
Second, yes, only one worksheet per workbook and they are all the first worksheet.
Third, yes, all cells in all worksheets are text.
Fourth, that was my error not included the file extension for the 'CHN DEC10 FINAL PENDED LIST' filename.
Thanks for looking at this!!!!
Thank you Pam :-)
Have you tried XLD's solution?
Yes, I did and it stopped at "Workbooks(i).Open"
Yes, I did and it stopped at "Workbooks(i).Open"
Ahh... Only as Bob (XLD) appears offline, change:
Workbooks(i).Open
To:
Workbooks.Open .SelectedItems(I)
I like Bob's because you can select only the files you want and do not have to fret over whether there might be other workbooks (that we do not want) in the same folder.
If we are certain that all the workbooks in the folder are wanted however, I was thinking of using the FolderPicker, so here is what I came up with:
Option Explicit
Public Sub CombineData()
Dim FSO As Object ' Scripting.FileSystemObject
Dim fsoFol As Object ' Scripting.Folder
Dim fsoFil As Object ' Scripting.File
Dim wks As Worksheet
Dim rngTemp As Range
Dim rngStart As Range
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = vbNullString
.InitialView = msoFileDialogViewDetails
.Title = "Pick the folder with all the files in it"
If .Show = -1 Then 'If user did not cancel...
'Set a reference to FileSystemObject and then to the Folder we picked.
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fsoFol = FSO.GetFolder(PathFixed(.SelectedItems(1)))
For Each fsoFil In fsoFol.Files
'If (hopefully) the file isn't open and it's a workbook...
If Not Trim$(Left(fsoFil.Name, 2)) = "~$" _
And fsoFil.Type Like "Microsoft Excel *Worksheet" Then
'Open and set a reference to the first worksheet...
Set wks = Workbooks.Open(fsoFil.Path, False, True).Worksheets(1)
Set rngTemp = Nothing
Set rngTemp = RangeFound(wks.Range("A:J"))
If Not rngTemp Is Nothing Then 'Test for blank sheet.
Set rngStart = Nothing
Set rngStart = RangeFound(shtResults.Range("A:J"))
If Not rngStart Is Nothing Then
'Set a reference to the source range (increased by one column)
Set rngTemp = Range(wks.Range("A2"), wks.Range("K" & rngTemp.Row))
'Plunk the filename in to bring across to destination range
rngTemp.Columns(11).Cells.Value = wks.Parent.Name
'Plunk in the values
shtResults.Range("A" & rngStart.Offset(1).Row) _
.Resize(rngTemp.Rows.Count, rngTemp.Columns.Count).Value = rngTemp.Value
Else
GoTo Jump
End If
Else
GoTo Jump
End If
End If
Jump: wks.Parent.Saved = True
wks.Parent.Close False
Next
shtResults.UsedRange.Columns.EntireColumn.AutoFit
End If
End With
End Sub
Public Function PathFixed(ByVal Path As String, _
Optional IncludeTrailingSeperator As Boolean = True _
) As String
Do While Right$(Path, 1) = "\"
Path = Left$(Path, Len(Path) - 1)
Loop
If IncludeTrailingSeperator Then Path = Path & "\"
PathFixed = Path
End Function
Function RangeFound(SearchRange As Range, _
Optional ByVal FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range
If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If
Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function
Hope that helps,
Mark
If your files reside in G:\OF\
sub M_snb()
sn=split(createobject("wscript.shell").exec("cmd /c Dir ""G:\OF\*.xlsx"" /b").stdout.readall,vbcrlf)
for j=0 to ubound(sn)
with getobject(sn(j)).sheets(1).usedrange
Thisworkbook.sheets(1).cells(rows.count,1).end(xlup).offset(1).resize(.rows .count,.columns.count)=.value
.parent.parent.close 0
end with
next
End Sub
Thanks so much! It's still producing an error at----- Set rngStart = RangeFound(shtResults.Range("A:J")) Error states variable not defined.
Sorry Pam, I should have explained that bit. See, worksheets and some other things have what is referred to as a CodeName Property. In VBE, look in the project's Project window (usually upper left) and double-click the worksheet you want to be the destination. Now down in the Properties window (for the worksheet's module) you will see two 'Name' properties. The upper one with parenthesis around it is the sheet's CodeName (check out CodeName in VBA Help).
Change this to: shtResults
Now even if someone changes the name on the sheet's tab, the code still works, as it refers to the codename/object name.
Mark
Thanks Mark! Sorry for the delayed response. Will give it a try. Thank you so very much for all your assistance!!!!! :)
Bob Phillips
01-20-2014, 05:10 AM
Yes, I did and it stopped at "Workbooks(i).Open"
Sorry Pam, lack of testing.
Workbooks(i).Open
should be
Workbooks.Open Filename:= .SelectedItems(i)
mancubus
01-20-2014, 05:39 AM
to append the file names to
If your files reside in G:\OF\
sub M_snb()End Sub just add
ThisWorkbook.Sheets(1).Cells(Rows.Count, .Columns.Count + 1).End(xlUp).Offset(1).Resize(.Rows.Count) = sn(j) before .parent.parent.close 0 line
Thank you all so very much; works like a charm!!!!!!!
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.