Extract multi excel file into a single file

Hi saputroa272

Originally Posted by saputroa272

hello, I am trying to extract many profiles & product files into single file.
on sheet "Merchant" had succeeded but for sheet "Produk" has not been successful.
here it is my code………
and here is my files……

. You need to give us much more information in order for us to help you. It is good that you have given us the code – that is a good start point for us. And you have given us the “Before File” Extract Multifile trial.xlsm . But from the information that you have given we can have no idea what is going wrong as you have not stated clearly exactly how you want the File “Extract Multifile trial.xlsm” to look like after successful running of a code.
. Please in future provide a second “Extract Multifile trial File” ,( the “After” File ) which you fill in by hand to show exactly what output you want finally after a successful running of a code
……..
. In any case I have made a few guesses as to what you want and rewritten your code so that it consolidates profiles & product files into the File “Extract Multifile trial.xlsm” assuming that “Extract Multifile trial.xlsm” would be empty to begin with:--***
. - I think your main problem in your original code was in determining your Nextfree2 -
. a) ***File “Extract Multifile trial.xlsm” appeared to have some data in a long way down in sheet Produk that you may have overlooked
. b) even when deleting this data your calculation of NextFree2 seemed to give erratic results which I do not yet understand. I had to empty cells which looked empty to get the codes too work. But I am not sure if you intended having this data there?***
. But I have also simplified greatly your 'copy, paste, whatever stuff” as well. ( Assuming for now you have no empty rows within the data to be consolidated as per your sample data )

Code:

Option Explicit
Sub Button1_Click()
Dim vaFiles As Variant
    Dim i As Long
    Dim WB As Workbook
    
    vaFiles = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", Title:="Select files", MultiSelect:=True)
    
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
            Set WB = Workbooks.Open(Filename:=vaFiles(i))
 
            'copy, paste, whatever, for merchant
            Dim NextFree As Long
              NextFree = ThisWorkbook.Sheets("Merchant").Cells(Rows.Count, 2).End(xlUp).Row + 1 'Last cell in Column 2 has end property ( argument "going upwards" (xlup)) applied which returns a new range ( cell ) with last entry in it, to which the .Row property retuns the row number. + 1 give next free cell
            
            WB.Sheets("Merchant").Range("C4:C13").Copy 'Copy column to clipboard assuming it is always same size, same position in WB
            ThisWorkbook.Sheets("Merchant").Range("B" & NextFree & "").PasteSpecial Paste:=xlPasteAll, Transpose:=True 'Paste to next free row in This workbook Merchant sheet. ( Need to Transpose to change Column to Row )
            
            'copy, paste, whatever, for Produk
            Dim Nextfree2 As Long
             Nextfree2 = ThisWorkbook.Sheets("Produk").Range("B2:B" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
            Dim lastProduk As Long
             Let lastProduk = WB.Worksheets("Produk").Cells(Rows.Count, 4).End(xlUp).Row
            
             WB.Worksheets("produk").Range("C3:M" & lastProduk & "").Copy Destination:=ThisWorkbook.Worksheets("Produk").Range("B" & Nextfree2 & "") 'We only are interested in values so can use Copy Destination for entore range which is quicker by by-passing the clipboard
             
             WB.Close savechanges:=False
        Next i
    End If
End Sub

Alan Elston
Bavaria
Germany

Hi saputroa272
. Just a quick follow up here as I was working on a similar problem and had horrendous problems in checking for “Empty cells”……

. 1) Usually .Value would be taken as default if omitted. But interestingly here it leads to your code not working, that is to say NextFree2 seemed to give erratic results which does not appear to be the case with your modified code.
. A strange problem, but emphasizes as always not too rely on the default and always remember to include .Value….

. 2) There could still be some problems lurking to catch you out unexpectedly to do with “Empty cells”..
.. here is another code alternative ( 2 versions ) which my be more appropriate, or at least another alternative to have as a back- up..


Full code with explaining comments:

'
Sub Alan2()
Dim vaFiles As Variant
    Dim i As Long, k As Long 'Loop Bound variables counts'( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, For example Integer need converted internally anyways, so a Long is actually faster.
    Dim WB As Workbook 'used for files to be integrated in loop, set each time to specific WorkBook
    Dim wsProd As Worksheet, wsMerch As Worksheet 'Variables for Sheets in main Sheet
    Set wsProd = ThisWorkbook.Worksheets("Produk"): Set wsMerch = ThisWorkbook.Worksheets("Merchant") 'Give abbreviations Methods Properties, etc., of Worksheet Object
    
    With ThisWorkbook.Worksheets("Produk").Columns(2) 'Quick way to allow "one liner" code below to assign to large range
    .Value = .Value 'Important Initial step to ensure that Empty cells are Empty!!
    End With

    
    vaFiles = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", Title:="Select files", MultiSelect:=True)
    
    If IsArray(vaFiles) Then 'Chech we have profile and productfiles to work with
        For i = LBound(vaFiles) To UBound(vaFiles)
            Set WB = Workbooks.Open(Filename:=vaFiles(i))
 
            'copy, paste, whatever, for merchant
            Dim Nextfree As Long
              Nextfree = wsMerch.Cells(Rows.Count, 2).End(xlUp).Row + 1 'Last cell in Column 2 has end property ( argument "going upwards" (xlup)) applied which returns a new range ( cell ) with last entry in it, to which the .Row property retuns the row number. + 1 give next free cell
            
            WB.Sheets("Merchant").Range("C4:C13").Copy 'Copy column to clipboard assuming it is always same size, same position in WB
            ThisWorkbook.Sheets("Merchant").Range("B" & Nextfree & "").PasteSpecial Paste:=xlPasteAll, Transpose:=True 'Paste to next free row in This workbook Merchant sheet. ( Need to Transpose to change Column to Row )
            
            'copy, paste, whatever, for Produk
            Dim Nextfree2 As Long
                For k = 3 To 251 'Check down a large number of rows
                        If WB.Sheets("Produk").Range("C" & k).Value <> "" Then 'This will only check for a value present, not if it is Not Empty: Overcomes the problem if no value is there but some formating which would possibly be then taken as Not Empty
                            Nextfree2 = wsProd.Range("B2:B" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row 'Find next Empty cell in column 2 in Produk sheet in main File
                            WB.Worksheets("produk").Range("C" & k & ":M" & k & "").Copy 'Copy entire required range from Profile and Product file
                            wsProd.Range("B" & Nextfree2 & "").PasteSpecial xlPasteValues 'Pasting in the copied range in Main Sheet. ( Paste, or Paste Destination:= woulde also work here )
                        Else 'If cell in column C has no value in it, take no action: Redundant code
                        End If
                Next k 'Check next row in profile and product File
             WB.Close savechanges:=False 'Close profile and product , using argument to ignorebeing asked to save changes
        Next i 'go to next profile and product File
    End If
End Sub

Shortened / Simplified code:

'
Sub Alan2SHimpfGlified()
    Dim vaFiles, i As Long, k As Long
    Dim WB As Workbook
    Dim wsProd As Worksheet, wsMerch As Worksheet
    Set wsProd = ThisWorkbook.Worksheets("Produk"): Set wsMerch = ThisWorkbook.Worksheets("Merchant")
    
    With ThisWorkbook.Worksheets("Produk").Columns(2)
    .Value = .Value
    End With
  
    vaFiles = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", Title:="Select files", MultiSelect:=True)
    
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
            Set WB = Workbooks.Open(Filename:=vaFiles(i))
 
'copy, paste, whatever, for merchant
            WB.Sheets("Merchant").Range("C4:C13").Copy
            ThisWorkbook.Sheets("Merchant").Range("B" & wsMerch.Cells(Rows.Count, 2).End(xlUp).Row + 1 & "").PasteSpecial Paste:=xlPasteAll, Transpose:=True
'----
'copy, paste, whatever, for Produk
                For k = 3 To 251
                        If WB.Sheets("Produk").Range("C" & k).Value <> "" Then
                            WB.Worksheets("produk").Range("C" & k & ":M" & k & "").Copy Destination:=wsProd.Range("B" & wsProd.Range("B2:B" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row & "")
                        End If
                Next k
             WB.Close savechanges:=False
'----
        Next i
    End If
End Sub

Alan

Originally Posted by saputroa272

Hi Doc.AElstein
1. noted sir
2. superb, both of them are worked fine. Its good for me as a back- up if i find a problem with “Empty cells”
thanks a alot

. You're welcome,
. Thanks for the feedback.
. Alan Elston