Lots of help Please

[CDaviess]

Hi all,

I am Currently working on a VBA that is able to open lots of workbooks from within a folder, each of these workbooks only has 1 work sheet, this work sheet will have multiple columns and 1000s of rows. I have an identifier in Row R that I use to separate the data. I then want excel to run through each of these workbooks and separate the data and paste it into a separate Master workbook with a separate worksheet for each identifier. I have a good start that loops through each of the workbooks and takes the data, (not in the most efficient way..) however im finding that sometimes excel wont copy and paste all of the data or it will put a single line right a the very top and the rest below from another sheet. Code and images attached below, sorry if this doesnt make the most sense.

From 'OP1, the same code is then copy and pasted down to OP20, which is why I don't understand the error.

Any help to make this more efficient and work 100% of the time would be greatly appreciated!!

Many thanks.

 

[Bill Rockenbach]

Please re-post with your code copy/pasted and then enclosed in vba tags. Do not post code as an image.

 

[mumps]

Do the identifier sheets already exist in the Master workbook or do they have to be created by the macro? If they already exist, do they already contain the headers in row1?

 

[montecarlo2012]

Hello, I see you just start.
so just take a look of the ribbon

click on VBA and copy/paste your code, will be better when somebody need to help

 

[montecarlo2012]

I will try to give you a hand here.
first the logic of your problem, so let me give you a write version of a flowchart

Start

 1 Create Master Workbook with Separate Worksheets for Each Identifier in Row R


Loop Through Each Workbook in Specified Folder


Open Workbook and Set Data Worksheet

Find Last Row in Data Worksheet


Loop Through Each Row in Data Worksheet


Check Identifier in Column R


If Identifier Exists, Copy Row of Data


Find Corresponding Worksheet in Master Workbook


Find Next Empty Row in Corresponding Worksheet


Paste Row of Data into Corresponding Worksheet


Move to Next Row in Data Worksheet


Close Workbook


Repeat for Next Workbook in Folder


End

And here's some VBA code that should do what you're looking for.

First, you'll need to create a new workbook that will serve as the master workbook. This workbook should have a separate worksheet for each identifier in row R. Name each worksheet with the corresponding identifier.

Then, you can use the code below to loop through each workbook in a specified folder, copy the data based on the identifier in row R, and paste it into the appropriate worksheet in the master workbook.

Sub CombineWorkbooks()
    
    Dim MyPath As String
    Dim MyFile As String
    Dim WB As Workbook
    Dim wsMaster As Worksheet
    Dim wsData As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    'Set the path to the folder containing the workbooks
    MyPath = "C:\MyFolderPath\"
    
    'Set the master workbook and worksheet
    Set wsMaster = ThisWorkbook.Sheets("MasterSheet")
    
    'Loop through each file in the folder
    MyFile = Dir(MyPath & "*.xlsx")
    Do While Len(MyFile) > 0
        Set WB = Workbooks.Open(MyPath & MyFile)
        Set wsData = WB.Sheets(1)
        
        'Find the last row in the data worksheet
        lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
        
        'Loop through each row in the data worksheet
        For i = 1 To lastRow
            'Check the identifier in column R
            If wsData.Range("R" & i).Value <> "" Then
                'Copy the row of data
                wsData.Range("A" & i & ":Z" & i).Copy
                'Find the worksheet with the corresponding identifier
                Set wsDest = wsMaster.Parent.Sheets(wsData.Range("R" & i).Value)
                'Find the next empty row in the destination worksheet
                destLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
                'Paste the row of data
                wsDest.Range("A" & destLastRow).PasteSpecial xlPasteValues
            End If
        Next i
        
        'Close the workbook
        WB.Close savechanges:=False
        
        'Get the next file name
        MyFile = Dir
    Loop
    
End Sub

Make sure to update the MyPath variable to the path where your workbooks are located, and update the column references in the code to match the columns in your data worksheet.
I hope some how this ideas help you. by

 

[CDaviess]

Hi all, thank you for the responses, Sorry i am very new to this! The code will be pasted below, not all however as the code is massively the same. I already have something to create the Master Workbook.

Sub LoopThroughFiles()
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.xls*")
        Do While xFileName <> ""
            With Workbooks.Open(xFdItem & xFileName)
                'OP1
 Sheets(1).Activate
    Range("A1:S1").Copy
    Workbooks("Master").Sheets("OP1").Range("A1:S1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme                             'Pastes Headings in first row
    
    With Workbooks("Master").Worksheets("OP1").Columns("A")                                                                     'Format width of coloumns
     .ColumnWidth = .ColumnWidth * 1.5
    End With
    
    With Workbooks("Master").Worksheets("OP1").Columns("B:S").AutoFit                                                            'Format width of coloumns
        End With


Dim rw As Long, Cell As Range
For Each Cell In Sheets(1).Range("R:R")                                                                                         'Searches through each cell in column R for specific OP identifier
rw = Cell.Row
 If Cell.Value = "OP 1" Then
  Cell.EntireRow.Copy                                                                                                           'If OP found, copy onto new spreadsheet
   Workbooks("Master").Sheets("OP1").Range("A" & rw).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAllUsingSourceTheme      'Pastes data to the first empty row
     Application.ScreenUpdating = False                                                                                         'Stops Screen flickering

 End If
Next

Workbooks("Master").Worksheets("OP1").Rows("1:10000").HorizontalAlignment = xlCenter                                            'Aligns all text

'OP2
Sheets(1).Activate
    Range("A1:S1").Copy
    Workbooks("Master").Sheets("OP2").Range("A1:S1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme                             'Pastes Headings in first row
    
    With Workbooks("Master").Worksheets("OP2").Columns("A")                                                                     'Format width of coloumns
     .ColumnWidth = .ColumnWidth * 1.5
    End With
    
    With Workbooks("Master").Worksheets("OP2").Columns("B:S").AutoFit                                                            'Format width of coloumns
        End With



For Each Cell In Sheets(1).Range("R:R")                                                                                         'Searches through each cell in column R for specific OP identifier
rw = Cell.Row
 If Cell.Value = "OP 2" Then
  Cell.EntireRow.Copy                                                                                                           'If OP found, copy onto new spreadsheet
   Workbooks("Master").Sheets("OP2").Range("A" & rw).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAllUsingSourceTheme      'Pastes data to the first empty row
     Application.ScreenUpdating = False                                                                                         'Stops Screen flickering

 End If
Next

Workbooks("Master").Worksheets("OP2").Rows("1:10000").HorizontalAlignment = xlCenter                                            'Aligns all text

 

[mumps]

All the code suggested so far involves looping. Given the multiple files and the large number of rows, the looping will be quite slow. Could you please answer my questions from Post #3?

 

[CDaviess]

Do the identifier sheets already exist in the Master workbook or do they have to be created by the macro? If they already exist, do they already contain the headers in row1?

Sorry I don't fully understand, I already have a macro to create the Master workbook, it just creates a new workbook and inserts sheets OP1 - OP20.

 

[mumps]

Give me a little bit of time and I'll get back to you.

 

[mumps]

Start with a new, blank workbook. This will be your Master. Place this macro in a standard module in the blank workbook. Save the workbook as a macro-enabled file using a name of your choice. Run the macro. You will be prompted to select the folder containing your source files. Once you select the folder and click "OK", the files will be processed.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim desWB As Workbook, desWS As Worksheet, srcWB As Workbook, LastRow As Long, v As Variant, i As Long
    Dim MyFile As String, MyFolder As String
    Set desWB = ThisWorkbook
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        MyFolder = .SelectedItems(1) & "\"
    End With
    MyFile = Dir(MyFolder)
    Do While MyFile <> ""
        Set srcWB = Workbooks.Open(Filename:=MyFolder & MyFile)
        v = Sheets(1).Range("R2", Sheets(1).Range("R" & Rows.Count).End(xlUp)).Value
        With CreateObject("scripting.dictionary")
            For i = LBound(v) To UBound(v)
                If Not .exists(v(i, 1)) Then
                    .Add v(i, 1), Nothing
                    If IsError(Evaluate("=ISREF('[" & desWB.Name & "]" & v(i, 1) & "'!$A$1)")) Then
                        With desWB
                            .Sheets.Add after:=.Sheets(.Sheets.Count)
                            .Sheets(.Sheets.Count).Name = v(i, 1)
                            Set desWS = .Sheets(.Sheets.Count)
                        End With
                        With Sheets(1)
                            .Range("A1").CurrentRegion.AutoFilter 18, v(i, 1)
                            .AutoFilter.Range.Copy desWS.Range("A1")
                        End With
                        With desWS
                            .Columns("A").ColumnWidth = .Columns("A").ColumnWidth * 1.5
                            .Columns("B:S").Columns.AutoFit
                        End With
                    Else
                        Set desWS = desWB.Sheets(v(i, 1))
                        With Sheets(1)
                            .Range("A1").CurrentRegion.AutoFilter 18, v(i, 1)
                            .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                        End With
                        With desWS
                            .Columns("A").ColumnWidth = .Columns("A").ColumnWidth * 1.5
                            .Columns("B:S").Columns.AutoFit
                        End With
                    End If
                End If
                
            Next i
            srcWB.Close False
        End With
        MyFile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub