modify Code from from manually choose a folder then a workbook to automatically go to folder and wor-CodePudding

the code bellow works fine all i want is to modify how it works . what does the code do : when running it provides the windows to choose a folder then choose a workbook then automatically copy some cells from the target workbook to another work book . the copying process part works fine .

i want to modify the part the prompt window shows up and manually choose folder and the workbook, i want to make it automatically go to the folder and copy data from all files within the folder

help please

    Sub Copy_specific_Cells_From_other_workbooks_with_file_prompt_msg()
    Application.ScreenUpdating = False
    Dim flder As FileDialog
    Dim Filename As String
    Dim FileChosen As Integer
    Dim wkbSource As Workbook
    Dim wkbDest As Workbook
    Set wkbDest = ThisWorkbook
    OpenFile:
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select an Excel File"
    flder.InitialFileName = "C:\Users\Okinawa Office\Downloads\TSSR REPORTS BATCH 07.08.2022"
    flder.InitialView = msoFileDialogViewSmallIcons
    flder.Filters.Clear
    flder.Filters.Add "Excel Files", "*.xls*"
    MsgBox ("Select a folder and then a file to open.")
    FileChosen = flder.Show
    Filename = flder.SelectedItems(1)
    Set wkbSource = Workbooks.Open(Filename)
    wkbSource.Sheets("Basic Information").Range("A2").Copy
    wkbDest.Sheets("Master").Cells(wkbDest.Sheets("Master").Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    wkbSource.Sheets("Basic Information").Range("A5").Copy
    wkbDest.Sheets("Master").Cells(wkbDest.Sheets("Master").Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    wkbSource.Close SaveChanges:=False
    If MsgBox("Do you want to open another workbook?", vbYesNo) = vbYes Then GoTo OpenFile
    End Sub

CodePudding user response：

I have tested the code below and it works for me.

Change sPath to the value you need.

Private Sub Copy_specific_Cells_From_other_workbooks_with_file_prompt_msg()

Dim FileName$, sPath$
Dim wkbDest As Workbook, wkbSource As Workbook
Dim wsDest As Worksheet, wsSource As Worksheet

Application.ScreenUpdating = False

'sPath = "C:\Users\Okinawa Office\Downloads\TSSR REPORTS BATCH 07.08.2022"
sPath = "C:\Users\user\Documents\HP Laptop\Documents\Documents\Jobs\DIT\IDMB\Stack Overflow\okinawa\"

Set wkbDest = ThisWorkbook
'setting worksheet to improve readability
Set wsDest = wkbDest.Sheets("Master")

FileName = Dir(sPath)
Do While Len(FileName) > 0
    'open workbook for read only
    Set wkbSource = Workbooks.Open(sPath & FileName)
    'setting worksheet to improve readability
    Set wsSource = wkbSource.Sheets("Basic Information")
    
    wsSource.Range("A2").Copy
    wsDest.Cells(wsDest.Rows.count, "A").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
    wsSource.Range("A5").Copy
    wsDest.Cells(wsDest.Rows.count, "B").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
    
    'not needed since we're closing the workbook; so it will be done automatically
    'Application.CutCopyMode = False
    
    wkbSource.Close SaveChanges:=False
    
    FileName = Dir
Loop

Application.ScreenUpdating = True

End Sub