Combine data range from multiple workbooks into one worksheet with additional variable

[jessrabbit]

Hello, I have searched for a solution to this requirement in the many examples which exist but can't find one that does what I need exactly and my vba skills are not good enough to adapt. I would greatly appreciate help from the excel expert community.

I'm trying to combine several BOM files into one worksheet which I can then use with a pivot table. All workbooks are located in one folder. The source workbooks are based upon the existence of several top level part no BOMs - each contains the enquiry date and top level part no in specific cells (A1 & B6) and then the BOM itself starts at row 12 in cells B12:ARx where the number of rows is a variable but the relevant rows always have a number in column B. If there isn't a number in column B from row 12 then the data isn't required. There is only one worksheet containing the BOM for a specific top level part number in each workbook.

The sequence would be;

1. Value of cell A1, B6 and data in range B12:ARx copied.
2. Data pasted into workbook containing the macro (which is located in a different folder to the source data workbooks) such that Cell values of A1 & B6 are repeated on each row pasted. Data from workbook 2 would be pasted under data from workbook 1 etc.
3. Close source workbook and open next workbook, repeat until all workbooks have been processed in the same way.

Please could somebody get me started with this or point me in the right direction?

Thank you,

Jess

 

[jessrabbit]

I have this code and wonder if it is a suitable starting point for modification.

The code below copies a specific range of data contained in multiple workbooks and pastes it as a picture into several worksheets in one workbook.

The new code should still take data from multiple workbooks but combine it into a single worksheet. Other differences are 1. the need to carry over the date and top level part number from specific cells and 2. the need to only copy data from row 12 on condition that column b contains a number.

Again, any help would be great. Thank you, Jess

Option Explicit




Const FOLDER_PATH = "C:\Users\(LIVE SOURCE)\"    'Must have the Backslash




Sub ImportWorksheets()
    '=============================================
    'Process all Excel files in specified folder
    '=============================================
    Dim sFile As String 'file to process
    Dim wsTarget As Worksheet
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim rowTarget As Long 'output row
    '
    Dim wbTarget As Workbook
    
    Set wbTarget = ThisWorkbook
    
    'check the folder exists
    If Not FileFolderExists(FOLDER_PATH) Then
        MsgBox "Specified folder does not exist, exiting!"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    'loop through the Excel files in the folder
    sFile = Dir(FOLDER_PATH & "*.xlsx*")
    Do Until sFile = ""
    
        'open the source file and set the source worksheet
        Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
        Set wsSource = wbSource.Worksheets("Dashboard")
        
        'import the data
        wsSource.Range("B2:Z62").Copy
        wbTarget.Sheets.Add after:=wbTarget.Sheets(wbTarget.Sheets.Count)
        Set wsTarget = wbTarget.ActiveSheet
        wbTarget.Activate
        wsTarget.Select
        ActiveSheet.Pictures.Paste.Select
        ActiveSheet.Shapes.Range(Array("Picture 1")).Select
        ActiveWindow.DisplayGridlines = False
        wsTarget.Name = Replace(sFile, ".xlsx", "")
        
        'close the source workbook, increment the output row and get the next file
        wbSource.Close SaveChanges:=False
        sFile = Dir()
    Loop
    
    Application.ScreenUpdating = True
    'tidy up
    Set wsSource = Nothing
    Set wbSource = Nothing
    Set wbTarget = Nothing
    Set wsTarget = Nothing
End Sub
'
Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

 

[jessrabbit]

Hello, is anyone able to help with this please?

Thank you

 

[GR00007]

This seems to work - it copies A12:N last row, just change N to AR

Sub BOM()
'
' BOM Macro
'   Housekeeping
    Dim sFile As String
    Dim wbTarget As Workbook
    Dim wbSource As Workbook
    Dim wsTarget As Worksheet
    Dim wsSource As Worksheet
    Dim vRow As Long
    Dim vLR As Long
    vRow = 2
    vPath = "C:\Me\Junk\Test\"
    vFileLike = "BOM*.xlsx"
    tFile = ThisWorkbook.Name
    Set wbTarget = ThisWorkbook
    Set wsTarget = wbTarget.Worksheets("CombinedBOM")
'   Get directory
    sFile = Dir(vPath & vFileLike)
    If sFile = "" Then
        MsgBox "No files found, exiting!"
        Exit Sub
    End If
    Do Until sFile = ""
        'Open source and find last row
        Set wbSource = Workbooks.Open(vPath & sFile)
        Set wsSource = wbSource.Worksheets("Sheet1")
        vLR = ActiveSheet.UsedRange.Rows.Count
        'Copy A1 and B6 from source to current row A & B
        wsTarget.Cells(vRow, "A") = wsSource.Cells(1, "A")
        wsTarget.Cells(vRow, "B") = wsSource.Cells(6, "B")
        'Activate source, filter on column B to exclude blank values
        Windows(sFile).Activate
        Rows("11:11").Select
        Selection.AutoFilter
        ActiveSheet.Range("$A$11:$N$" & vLR).AutoFilter Field:=2, Criteria1:="<>", Operator:=xlAnd
        'Count filtered rows, select filtered source columns and copy
        vFilteredRows = Range("A12:A" & vLR).SpecialCells(xlCellTypeVisible).Count
        Range("A12:N" & vLR).Select
        Selection.Copy
        'Activate target, paste copied range to current row column C
        Windows(tFile).Activate
        Range("C" & vRow).Select
        ActiveSheet.Paste
        'Turn off 'marching ants' of copy
        Application.CutCopyMode = False
        'Select and fill values in A&B for the number of visible rows less one.
        Range("A" & vRow & ":B" & vRow).Select
        Selection.AutoFill Destination:=Range("A" & vRow & ":B" & vRow + (vFilteredRows - 1)), Type:=xlFillDefault
        'Activate and close source without saving
        Application.CutCopyMode = False
        Windows(sFile).Activate
        Application.DisplayAlerts = False
        ActiveWindow.Close
        Application.DisplayAlerts = True
        'prepare for next loop, reset current row and obtain next file in directory
        vRow = vRow + vFilteredRows
        sFile = Dir
    Loop
End Sub

 

[John_w]

You haven't said exactly where A1, B6 and B12:ARx should be copied to in the macro workbook. Also, how does the code know which sheet in the source workbook contains the data to be copied?

See if this works as required. A1 is copied to column A, B6 is copied to column B, and B12:ARx are copied to column C and adjacent columns. The data is copied from the first sheet in each workbook.

Public Sub Copy_Range_From_Workbooks()

    Dim folderPath As String, fileName As String
    Dim destRow As Long
    Dim BOMwb As Workbook
    Dim lastRow  As Long
    
    'Folder containing the workbooks
    
    folderPath = "C:\path\to\folder\"                                 'CHANGE THIS
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    destRow = 1
    Application.ScreenUpdating = False
    fileName = Dir(folderPath & "*.xlsx")
    Do While fileName <> vbNullString
        Set BOMwb = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
        With BOMwb.Worksheets(1)
            If IsNumeric(.Range("B12").Value) Then
                lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
                ThisWorkbook.ActiveSheet.Cells(destRow, "A").Resize(lastRow - 12 + 1).Value = .Range("A1").Value
                ThisWorkbook.ActiveSheet.Cells(destRow, "B").Resize(lastRow - 12 + 1).Value = .Range("B6").Value
                .Range("B12:AR" & lastRow).Copy ThisWorkbook.ActiveSheet.Cells(destRow, "C")
                destRow = destRow + lastRow - 12 + 1
            End If
        End With
        BOMwb.Close False
        DoEvents
        fileName = Dir
    Loop
    Application.ScreenUpdating = True
    
    MsgBox "Finished"
    
End Sub

 

[jessrabbit]

You are right, I didn't specify but you have put them exactly where I wanted them and the code works perfectly. Please would you let me know how to make one modification so that the data is pasted into sheet2 in the new workbook?

Thank you very much,

Jess

 

[jessrabbit]

I've just noticed something else. May I also ask for help to preserve numerical values in the source worksheets as numbers in the new worksheet please?

Thank you,

Jess

 

[John_w]

You are right, I didn't specify but you have put them exactly where I wanted them and the code works perfectly. Please would you let me know how to make one modification so that the data is pasted into sheet2 in the new workbook?

Add this line after the ScreenUpdating = False.

ThisWorkbook.Worksheets(2).Activate

I've just noticed something else. May I also ask for help to preserve numerical values in the source worksheets as numbers in the new worksheet please?

In my testing, all numerical values are copied and preserved as numerical values in the destination sheet. Can you give examples where this doesn't happen?

 

[jessrabbit]

Thank you very much for the additional line of code to introduce Sheet2 which works great and the numerical format problem has also been resolved.

Best wishes,

Jess