HELP!! can't figure out details for a file-combining macro

[Radoras]

Hello everyone,

as a new wannabe-VBA programmer, I am struggling with a bit more complex Macro/Code & would appreciate some help from more experienced users:

The code I compiled (shown below) is supposed to archieve the following goal (which works so far):
- select a set of Excel files in a folder (daily updated, increasing number of source files which are saved into a "Database" folder)
- chain these excel-files together below each other
- "paste" the chained-together data sets into the open sheet of another excel file (to be used as a reference "database" for different formulas on another sheet in the same excel-file

This I archieved with the following code:


Sub File_Update ()
On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varData As Variant
Dim varNumber As Long
Dim lngLastQ As Long
Dim numberrows As Integer
Dim countrows As Integer
Dim i As Long
Dim sRow AsLong
Dim eRow AsLong
Set WBZ = ThisWorkbook
WBZ.Worksheets(1).Range("A1:IV65536").ClearContents
varData = _
Application.GetOpenFilename("File(*.xl*),*.xls", False, "Please mark selected file(s)", False,True)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation =xlCalculationManual
End With
For varNumber = LBound(varData) To UBound(varData)
Set WBQ =Workbooks.Open(Filename:=varData(varNumber))
ThisWorkbook.Activate
lngLastQ =WBQ.Worksheets(1).Range("A1").End(xlDown).Row
With WBZ.Worksheets(1)
sRow =.Cells(Rows.Count, "C").End(xlUp).Row + 1
WBQ.Worksheets(1).Range("A15:Y" & lngLastQ).Copy
.Range("C" & sRow).PasteSpecial Paste:=xlPasteValues
eRow = .Cells(Rows.Count, "C").End(xlUp).Row
.Range("AA" & sRow).AutoFillDestination:=.Range("AA" & sRow & ":AA" & eRow),Type:=xlFillCopy
End With
WBQ.Close
Next varNumber
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation =xlCalculationAutomatic
.CutCopyMode = False
End With
Range("A1").Select
MsgBox "In total" & UBound(varData)& " files were combined.", 64
Exit Sub
errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
If Err.Number = 13 Then
MsgBox "No files were selected"
Else
MsgBox "An error occured!" & vbCr _
& "Error No.: " & Err.Number & vbCr _
& "Error Description: " & Err.Description
End If
End Sub

However what I am trying to add into this code, but don't really know if/how it can be done:
Copy a varying "serial number" (one from each source file) from cell "D8" & add it in front of a variable amount of rows from each source file before original row A before the files are chained below each other.

Background for this is that, each serial number (Cell D8) is connected to several testing values, but each source file has a different amount of tests done (thus different amount of rows with test values).
E.g. Sourcefile A with serial number "1234" in D8 having results of 2 different test results - in rows 11 & 12 - , while Sourcefile B with serial number "5678" has 3 different test results, meaning test values in rows 11 - 13); these test values have to be tied/refereneced with the respective serial number (currently, the plan is to use VLOOKUP in another sheet to reference the serial number & display all test results belonging to this serial number.



- My inial idea for an approach was to e.g. use the formula "COUNTA" from row 11 several rows down (thus detecting the amount of rows that have values in them) & try to have the serial number copied into row 11 (right left of the first test value, because each dataset has at least 1) & then have it filled down an amount of rows equal to the result of "COUNTA"-1.

Unfortunately, I can't figure out how to include this into the already set-up formula so the serial number is copied at the start of row 11 (& each row containing test results below it) before chaining the source files together, since I can't think of a way to make it work after the files have already been compiled to 1 list.

Thank you very much in advance for your feedback!

[p45cal]

See comments in code as well as disabled lines and added lines and changes. Minimal changes to your code only:
Sub File_Update2()
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varData As Variant
Dim varNumber As Long
Dim lngLastQ As Long
Dim RowCountOfCopiedBlock As Long, Destn As Range
'Dim numberrows As Integer
'Dim countrows As Integer
'Dim i As Long

On Error GoTo errExit
Set WBZ = ThisWorkbook
WBZ.Worksheets(1).UsedRange.ClearContents 'changed
Set Destn = WBZ.Worksheets(1).Range("A1") 'added; change to A2 if you want stuff to start on row 2.
varData = Application.GetOpenFilename("File(*.xl*),*.xls", False, "Please mark selected file(s)", False, True)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
For varNumber = LBound(varData) To UBound(varData)
Set WBQ = Workbooks.Open(Filename:=varData(varNumber))
'ThisWorkbook.Activate
lngLastQ = WBQ.Worksheets(1).Range("A1").End(xlDown).Row
RowCountOfCopiedBlock = lngLastQ - 15 + 1
With WBQ.Worksheets(1) 'changed from WBZ
'sRow = .Cells(Rows.Count, "C").End(xlUp).Row + 1'Destn handles this.
' WBQ.Worksheets(1).Range("A15:Y" & lngLastQ).Copy
'.Range("C" & sRow).PasteSpecial Paste:=xlPasteValues
Destn.Resize(RowCountOfCopiedBlock, 25).Value = .Range("A15:Y" & lngLastQ).Value
Destn.Offset(, 25).Resize(RowCountOfCopiedBlock).Value = .Range("D8")
' eRow = .Cells(Rows.Count, "C").End(xlUp).Row
' .Range("AA" & sRow).AutoFill Destination:=.Range("AA" & sRow & ":AA" & eRow), Type:=xlFillCopy
Set Destn = Destn.Offset(RowCountOfCopiedBlock)
End With
WBQ.Close
Next varNumber
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With
Range("A1").Select
MsgBox "In total " & UBound(varData) & " files were combined.", 64
Exit Sub
errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
If Err.Number = 13 Then
MsgBox "No files were selected"
Else
MsgBox "An error occured!" & vbCr & "Error No.: " & Err.Number & vbCr & "Error Description: " & Err.Description
End If
End Sub

[Radoras]

Hello P45cal!

first of all, thank you for your help & suggested adjustments; however, when I tried your formula, I got the following error message:

1004
Application-defined or object-defined error

I tried stepping into the macro & figuring out at what point exactly it went wrong & got the error message at:


Set WBQ = Workbooks.Open(Filename:=varData(varNumber))

Another difference I noticed was that - different from the original macro version - the first source file (from the selected folder, which should be combined) was actually opened & remained on when the error occured, whereas in my original version, nothing was displayed on-screen until the files were done combining due to


With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual

I am trying to figure out how to solve this error, but so far couldn't get it yet (maybe because I haven't used the replacement code you suggested yet).

Thank you in advance for your feedback!

[p45cal]

I have just tested the code in my previous message by pasting it from here into a new workbook and running it. No problems encountered.
Did you try and copy changes I made into your code, or copy it wholesale as a new sub?

ps. When code is interrupted by an error things show that you wouldn't normally see.

[snb]

Basically you only need this (after adapting the path in 'initialfilename')


Sub M_snb()
With Application.FileDialog(3)
.AllowMultiSelect = True
.InitialFileName = "G:\OF\*.xls"

If .Show Then
ReDim sp(.SelectedItems.Count - 1)
For j = 0 To .SelectedItems.Count
With GetObject(.SelectedItems(j + 1))
sp(j - 1) = .Sheets(1).UsedRange.Value
.Close 0
End With
Next

With ThisWorkbook.Sheets(1)
.Cells.Clear
For j = 0 To UBound(sp)
.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sp(j)), UBound(sp(j), 2)) = sp(j)
Next
End With
End If
End With
End Sub

NB. But you should consider first why you distributed these data to several files in the first place. Keep together what belongs together (the adagium of every database).

[Radoras]

Thanks for the quick reply.

to be honest, I tried both (first just inserting parts to see how it would change the outcome, since I'm trying to understand the changes as well), but when it didn't work, I copied the whole code (assuming maybe I had inserted it wrong or some parts I copied in may not work on their own for some reason), but still got the same error.

I tried entering my old version again (which still works) & checked if there is anything odd with the source-files in the folder that are supposed to be combined; is the changed formula maybe not compatible with

- merged cells
- files containing pictures (a logo included as a picture in each source-file)?

[Radoras]

hello snb

thank you for your input; I tried using your code, but got the message:

Runtime error '9':
Subscript out of range

The reason the data is in several files is that I didn't actually create them, but rather receive the files from a 3rd party individually (as said, test results regarding different serial numbers, which are sent piece-by-piece as the restults for individual serial numbers become available).
At this point, the procedure is a lot of manual work (opening the "database-file", opening each test-result-file I receive indivually, then copy-pasting the values into the database) to be used by formulas along with other data that is already in it on a different sheet; I am trying to use VBA to automate the process so that, in the end, the "database-file" can by updated in 1 click from the pool of received test result files saved in the same folder, saving me a lot of time - only problem is that my expierience with VBA so far consits of simple recording & adjustment, youtube-tutorials & reverse-engineering code from forums I found online to make it fit for my own purposes.

Thank you for your support!

[p45cal]

is the changed formula maybe not compatible with
- merged cells
- files containing pictures (a logo included as a picture in each source-file)? I doubt it, but maybe. Why don't you attach a couple of workbooks for us to test on?



Runtime error '9':
Subscript out of range
snb's subscripts are a little awry. The following should work but be aware the whole sheet is copied over and the serial no. in D8 isn't copied to all the rows:
Sub M_snb()
With Application.FileDialog(3)
.AllowMultiSelect = True
.InitialFileName = "G:\OF\*.xls"

If .Show Then
ReDim sp(.SelectedItems.Count - 1)
For j = 0 To .SelectedItems.Count - 1 'added -1
With GetObject(.SelectedItems(j + 1))
sp(j) = .Sheets(1).UsedRange.Value 'removed -1
.Close 0
End With
Next

With ThisWorkbook.Sheets(1)
.Cells.Clear
For j = 0 To UBound(sp)
.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sp(j)), UBound(sp(j), 2)) = sp(j)
Next
End With
End If
End With
End Sub

[Radoras]

Thanks for the correction p45cal;

I tried uploading 4 sample files (with example data, but layout & entries in the actual files are the same) as attachment.
Any insight on why it might not work is much appreciated; as stated, the goal is to (either before, during or after chaining the entries together to one list) add the serial number from D8 in front of each row with test results (now colums A-Gs in the concerned rows in the sample source-files).

[p45cal]

OK, I think I've got it; row 15 is the last row you want to copy from, not the first row.
Quick solution is to change one line in your original macro:

.Range("AA" & sRow).AutoFillDestination:=.Range("AA" & sRow & ":AA" & eRow),Type:=xlFillCopy
to:

WBQ.Worksheets(1).Range("D8").Copy .Range("AA" & sRow & ":AA" & eRow)

As an aside, are you ultimately looking to get something like this:
30056

[snb]

Succesfully integrated with:

Sub M_snb()
With Application.FileDialog(3)
.AllowMultiSelect = True
.InitialFileName = "J:\download\*.xlsx"

If .Show Then
ReDim sp(.SelectedItems.Count - 1)
For j = 0 To UBound(sp)
With GetObject(.SelectedItems(j + 1))
.Sheets(1).Cells.UnMerge
.Sheets(1).Cells(11, 8) = .Sheets(1).Cells(8, 4)
sp(j) = .Sheets(1).UsedRange.Offset(9 - (j > 0))
.Close 0
End With
Next

With ThisWorkbook.Sheets(1)
.Cells.Clear
For j = 0 To UBound(sp)
.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sp(j)), UBound(sp(j), 2)) = sp(j)
Next
End With
End If
End With
End Sub

[Radoras]

Hello snb & p45cal

regarding the first suggestion (to replace

.Range("AA" & sRow).AutoFillDestination:=.Range("AA" & sRow & ":AA" & eRow),Type:=xlFillCopy
with

WBQ.Worksheets(1).Range("D8").Copy .Range("AA" & sRow & ":AA" & eRow)
it for some reason doesn't work for me; instead, it shows the error message

438
Object doesn't support this property or method

when stepping in & going through all steps until the last "End If"before"End Sub


regarding snb's suggestion, it works perfectly (except maybe I would want to keep the "headers" for each colum if possibe); but I am now trying to add in a function to "fill down" column H at the end until the last non-empty row (because in the original, in the example with 3 test values, only one gets the serial number in front of it); if that (& as a bonus, the "header-issue") would work that would be exactly what I need!

[snb]

Simply:

Sub M_snb()
Application.ScreenUpdating = False
With Application.FileDialog(3)
.AllowMultiSelect = True
.InitialFileName = "J:\download\*.xlsx"

If .Show Then
ReDim sp(.SelectedItems.Count - 1)
For j = 0 To UBound(sp)
With GetObject(.SelectedItems(j + 1))
With .Sheets(1)
.Cells.UnMerge
.Cells(11, 8).Resize(.UsedRange.Rows.Count - 10) = .Cells(8, 4)
sp(j) = .UsedRange.Offset(9)
End With
.Close 0
End With
Next

With ThisWorkbook.Sheets(1)
.Cells.Clear
For j = 0 To UBound(sp)
.Cells(Rows.Count, 1).End(xlUp).Offset(Abs(j > 0)).Resize(UBound(sp(j)), UBound(sp(j), 2)) = sp(j)
Next
End With
End If
End With
End Sub

[snb]

You'd better ask for CSV-files from this file provider.