VBA Code Modification

Excel&VBA · Aug 17th 2020

I have a below code which is copy data from multiple workbooks into 1 workbook.sheet1 the code gives me message to press yes for further workbook and then further if the folder have 10 workbook then it will ask 9 times. I want to run this code without this YES option.

One more thing that is when i run this code then it should ask me to select the folder to copy the data from multiple workbooks.

any help would be appreciated.

Code

Sub FirstRows()
Application.ScreenUpdating = False
Dim MyFolder As String, MyFile As String, wbSrc As Workbook
Set shtDest = ThisWorkbook.Sheets("Sheet1")
ChDrive "Z:"
ChDir "C:\Users\shazir\Downloads\Example"
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False

MyFolder = .SelectedItems(1) & "\"
End With
MyFile = Dir(MyFolder)

Do While MyFile <> ""
Set wbSrc = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
Sheets("Masterbook").UsedRange.Copy
With shtDest
.Cells(.Rows.Count, "A").End(xlUp).Offset(5).PasteSpecial xlPasteFormats
.Cells(.Rows.Count, "A").End(xlUp).Offset(5).PasteSpecial xlPasteValues
End With

wbSrc.Close SaveChanges:=True
MyFile = Dir
Application.ScreenUpdating = True
Loop
End Sub

Display More

**royUK** · Aug 18th 2020

There's no msgbox in the code, it should work on all files in the folder.

I would not copy the used range though.

Excel&VBA · Aug 18th 2020

Below message is display after initiating the code for each workbook available in folder.

There is 2nd thing that i don't want to paste the folder link. After initiating the code it should ask me to select the folder.

**royUK** · Aug 18th 2020

Try this

Code

Sub FirstRows()
    With Application
        .ScreenUpdating = False
        Dim MyFolder As String, MyFile As String, wbSrc As Workbook
        Set shtDest = ThisWorkbook.Sheets("Sheet1")
        '    ChDrive "Z:"
        ChDir "C:\Users\shazir\Downloads\Example"

        With .FileDialog(msoFileDialogFolderPicker)
            .Title = "Please select a folder"
            .Show
            .AllowMultiSelect = False
            MyFolder = .SelectedItems(1) & "\"
        End With
        MyFile = Dir(MyFolder)
        Do While MyFile <> ""
            Set wbSrc = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
            Sheets("Masterbook").UsedRange.Copy
            With shtDest
                .Cells(.Rows.Count, "A").End(xlUp).Offset(5).PasteSpecial xlPasteFormats
                .Cells(.Rows.Count, "A").End(xlUp).Offset(5).PasteSpecial xlPasteValues
                .CutCopyMode = False
            End With
            wbSrc.Close SaveChanges:=True
            MyFile = Dir
        Loop
        .ScreenUpdating = True
    End With
End Sub

Display More

Excel&VBA · Aug 18th 2020

below error is occurring on this line .CutCopyMode = False

**royUK** · Aug 18th 2020

I see, try this.

Code

Sub FirstRows()
With Application
.ScreenUpdating = False
Dim MyFolder As String, MyFile As String, wbSrc As Workbook
Set shtDest = ThisWorkbook.Sheets("Sheet1")
'    ChDrive "Z:"
ChDir "C:\Users\shazir\Downloads\Example"


With .FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
MyFolder = .SelectedItems(1) & "\"
End With
MyFile = Dir(MyFolder)
Do While MyFile <> ""
Set wbSrc = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
Sheets("Masterbook").UsedRange.Copy
With shtDest
.Cells(.Rows.Count, "A").End(xlUp).Offset(5).PasteSpecial xlPasteFormats
.Cells(.Rows.Count, "A").End(xlUp).Offset(5).PasteSpecial xlPasteValues
End With
.CutCopyMode = False
wbSrc.Close SaveChanges:=True
MyFile = Dir
Loop
.ScreenUpdating = True
End With
End Sub

Display More

Excel&VBA · Aug 18th 2020

Thank you so much. Its working but i have also requested to select a folder via Code rather than pasting link in code.

**royUK** · Aug 18th 2020

You have a FolderPicker in the code.

This line is unnecessary

Code

ChDir "C:\Users\shazir\Downloads\Example"

Excel&VBA · Aug 18th 2020

Thank you so much i deleted that line.

**royUK** · Aug 18th 2020

Is it working how you expect now?

Excel&VBA · Aug 18th 2020

Yes it is exactly working as i requested Thanks.

**royUK** · Aug 18th 2020

Pleased to help.

VBA Code Modification

Participate now!

Share