Lots of help Please

C

CDaviess

New Member
Joined
Mar 22, 2023
Messages
17
Office Version
  1. 365
Platform
  1. Windows
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.

1679498527372.png


1679498565991.png


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.
 
Sort by date Sort by votes
mumps said:
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.
VBA Code: 
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
Click to expand...
That is amazing thank you so much! Just me being anal, where would insert something to centre all the text, i know the way i did it last time is not optimal
 
Upvote 0

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Try:
VBA Code: 
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
                            .Cells.HorizontalAlignment = xlCenter
                        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
                            .Cells.HorizontalAlignment = xlCenter
                        End With
                    End If
                End If
                
            Next i
            srcWB.Close False
        End With
        MyFile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
mumps said:
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.
VBA Code: 
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
Click to expand...
That is amazing thank you! i should be okay with getting the formatting and such down
 
Upvote 0
mumps said:
Try:
VBA Code: 
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
                            .Cells.HorizontalAlignment = xlCenter
                        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
                            .Cells.HorizontalAlignment = xlCenter
                        End With
                    End If
                End If
               
            Next i
            srcWB.Close False
        End With
        MyFile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
Click to expand...
Sorry didnt see the second page!
 
Upvote 0
Is everything working as your requested now? Also, to tidy things up a bit, replace this line of code:
VBA Code: 
.Cells.HorizontalAlignment = xlCenter
with this one:
VBA Code: 
.UsedRange.Cells.HorizontalAlignment = xlCenter
 
Upvote 0
mumps said:
Is everything working as your requested now? Also, to tidy things up a bit, replace this line of code:
VBA Code: 
.Cells.HorizontalAlignment = xlCenter
with this one:
VBA Code: 
.UsedRange.Cells.HorizontalAlignment = xlCenter
Click to expand...
All replaced thank you!
I know you have already done so much, would you be able to just explain what everything does. i would like to understand this more
 
Upvote 0
Here is the code with some explanatory comments. I hope this helps.
VBA Code: 
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) 'allows selection of desired folder
        .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 <> "" 'loops through files in the selected folder
        Set srcWB = Workbooks.Open(Filename:=MyFolder & MyFile) 'opens the files
        v = Sheets(1).Range("R2", Sheets(1).Range("R" & Rows.Count).End(xlUp)).Value 'assigns values in column R to an array variable (v)
        With CreateObject("scripting.dictionary") 'creates a dictionary to store column R values
            For i = LBound(v) To UBound(v) 'loops through the array
                If Not .exists(v(i, 1)) Then 'check if the R columns value already exists in the dictionary
                    .Add v(i, 1), Nothing 'adds column R value to the dictionary if it doesn't already exist
                    If IsError(Evaluate("=ISREF('[" & desWB.Name & "]" & v(i, 1) & "'!$A$1)")) Then 'checks if new sheet exists in Master
                        With desWB
                            .Sheets.Add after:=.Sheets(.Sheets.Count) 'if new sheet doesn't exist, it is added to Master
                            .Sheets(.Sheets.Count).Name = v(i, 1) 'renames the new sheets according to column R value
                            Set desWS = .Sheets(.Sheets.Count)
                        End With
                        With Sheets(1)
                            .Range("A1").CurrentRegion.AutoFilter 18, v(i, 1) 'autofilters Sheet1 based on column R value
                            .AutoFilter.Range.Copy desWS.Range("A1") 'copies filtered data to newly created sheet at Range A1
                        End With
                        With desWS 'formats newly createe sheet
                            .Columns("A").ColumnWidth = .Columns("A").ColumnWidth * 1.5
                            .Columns("B:S").Columns.AutoFit
                            .UsedRange.Cells.HorizontalAlignment = xlCenter
                        End With
                    Else 'if new sheet already exists
                        Set desWS = desWB.Sheets(v(i, 1))
                        With Sheets(1)
                            .Range("A1").CurrentRegion.AutoFilter 18, v(i, 1) 'autofilters Sheet1 based on column R value
                            .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1) 'copies filtered data to newly created sheet at first blank row
                        End With
                        With desWS 'formats newly createe sheet
                            .Columns("A").ColumnWidth = .Columns("A").ColumnWidth * 1.5
                            .Columns("B:S").Columns.AutoFit
                            .UsedRange.Cells.HorizontalAlignment = xlCenter
                        End With
                    End If
                End If
            Next i
            srcWB.Close False 'closes source workbook wihtout saving
        End With
        MyFile = Dir
    Loop 'opens next file
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
mumps said:
Here is the code with some explanatory comments. I hope this helps.
VBA Code: 
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) 'allows selection of desired folder
        .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 <> "" 'loops through files in the selected folder
        Set srcWB = Workbooks.Open(Filename:=MyFolder & MyFile) 'opens the files
        v = Sheets(1).Range("R2", Sheets(1).Range("R" & Rows.Count).End(xlUp)).Value 'assigns values in column R to an array variable (v)
        With CreateObject("scripting.dictionary") 'creates a dictionary to store column R values
            For i = LBound(v) To UBound(v) 'loops through the array
                If Not .exists(v(i, 1)) Then 'check if the R columns value already exists in the dictionary
                    .Add v(i, 1), Nothing 'adds column R value to the dictionary if it doesn't already exist
                    If IsError(Evaluate("=ISREF('[" & desWB.Name & "]" & v(i, 1) & "'!$A$1)")) Then 'checks if new sheet exists in Master
                        With desWB
                            .Sheets.Add after:=.Sheets(.Sheets.Count) 'if new sheet doesn't exist, it is added to Master
                            .Sheets(.Sheets.Count).Name = v(i, 1) 'renames the new sheets according to column R value
                            Set desWS = .Sheets(.Sheets.Count)
                        End With
                        With Sheets(1)
                            .Range("A1").CurrentRegion.AutoFilter 18, v(i, 1) 'autofilters Sheet1 based on column R value
                            .AutoFilter.Range.Copy desWS.Range("A1") 'copies filtered data to newly created sheet at Range A1
                        End With
                        With desWS 'formats newly createe sheet
                            .Columns("A").ColumnWidth = .Columns("A").ColumnWidth * 1.5
                            .Columns("B:S").Columns.AutoFit
                            .UsedRange.Cells.HorizontalAlignment = xlCenter
                        End With
                    Else 'if new sheet already exists
                        Set desWS = desWB.Sheets(v(i, 1))
                        With Sheets(1)
                            .Range("A1").CurrentRegion.AutoFilter 18, v(i, 1) 'autofilters Sheet1 based on column R value
                            .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1) 'copies filtered data to newly created sheet at first blank row
                        End With
                        With desWS 'formats newly createe sheet
                            .Columns("A").ColumnWidth = .Columns("A").ColumnWidth * 1.5
                            .Columns("B:S").Columns.AutoFit
                            .UsedRange.Cells.HorizontalAlignment = xlCenter
                        End With
                    End If
                End If
            Next i
            srcWB.Close False 'closes source workbook wihtout saving
        End With
        MyFile = Dir
    Loop 'opens next file
    Application.ScreenUpdating = True
End Sub
Click to expand...
Amazing thank you, this is still a continuing project, im glad it seems i at least got most of the way there in a horribly inefficient way! I'm sure I will be calling on some more help in the future
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Question Question
Creating workbooks for a team of staff
Replies
1
Views
193
HighAndWilder
H
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
788
Micron
M
F
  • Question Question
Microsoft Forms from Excel Data
Replies
1
Views
110
igold
igold
Logit
  • Question Question
Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process
Replies
7
Views
275
Logit
Logit
V
  • Question Question
Copy Range from Multiple Sheets and Paste Link into a Single Sheet
Replies
2
Views
162
vbascientist
V

Forum statistics

Threads
1,223,714
Messages
6,174,052
Members
452,542
Latest member
Bricklin

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top