Repetitive Task

[Chang Chang]

Can someone help me with this repetitive task? I need to pull data from a file located in multiple folders with the same file name, then copy selected data into one file.


Network drive name: \\USA\Sales\Inventory
Folder name: Glass
Sub folder: Sales1, Sales2, Sales3, Sales4, … …
File Name: Inventory.xlsx
Data: Cell B4, B5, D6, E8
Combined file name: All.xlsx




The manual process is:

1. Open file All.xlsx
2. Open file Invenotry.xlsx in folder Sales1
3. Copy cell B4, B5, D6, E8
4. Paste date to file All.xlsx in cell row 6 column C, D, E, F (increment row for the next file; in this case, 7; keep the same columns)
   
5. Close file Inventory.xlsx
6. Select the next folder (Sales2)
   
7. Repeat step 2 to 6
8. Stop when the last folder (SalesXXX) is completed

Thank you in advance.

 

[Fluff]

How about

Sub getData()
   Dim Wbk As Workbook
   Dim Ws As Worksheet
   Dim fso As Object
   Dim Fldr As Object
   Dim Rng As Range
   Dim i As Long, Rw As Long
   
   Rw = 6
   Set Ws = ThisWorkbook.Sheets("[COLOR=#ff0000]data[/COLOR]")
   Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
   For Each Fldr In fso.GetFolder("[SIZE=2][FONT=verdana][COLOR=#000000]\\USA\Sales\Inventory\Glass[/COLOR][/FONT][/SIZE]\").subfolders
      If Fldr.Name Like "Sales*" Then
         Set Wbk = Workbooks.Open(Fldr.Path & "\Inventory.xlsx")
         For Each Rng In Wbk.Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Range("B4,B5,D6,E8")
            Ws.Range("C" & Rw).Offset(, i).Value = Rng.Value
            i = i + 1
         Next Rng
         Wbk.Close False
         i = 0: Rw = Rw + 1
      End If
   Next
End Sub

This needs to go in the Combined file, which will need to be saved as an xlsm.
Change sheet names in red to suit

 

[Chang Chang]

Hi Fluff,
For the "data" in your VBA (red font), do I need to change it to something else?

Thank you in advance.

How about

Sub getData()
   Dim Wbk As Workbook
   Dim Ws As Worksheet
   Dim fso As Object
   Dim Fldr As Object
   Dim Rng As Range
   Dim i As Long, Rw As Long
   
   Rw = 6
   Set Ws = ThisWorkbook.Sheets("[COLOR=#ff0000]data[/COLOR]")
   Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
   For Each Fldr In fso.GetFolder("[SIZE=2][FONT=verdana][COLOR=#000000]\\USA\Sales\Inventory\Glass[/COLOR][/FONT][/SIZE]\").subfolders
      If Fldr.Name Like "Sales*" Then
         Set Wbk = Workbooks.Open(Fldr.Path & "\Inventory.xlsx")
         For Each Rng In Wbk.Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Range("B4,B5,D6,E8")
            Ws.Range("C" & Rw).Offset(, i).Value = Rng.Value
            i = i + 1
         Next Rng
         Wbk.Close False
         i = 0: Rw = Rw + 1
      End If
   Next
End Sub

This needs to go in the Combined file, which will need to be saved as an xlsm.
Change sheet names in red to suit

 

[Fluff]

Yes, you need to change those sheet names to what ever your sheets are called