VBA to extract data from multiple folders and add to a master workbook plus identifying tags

[Bobbybazza]

Hi all, thanks for your time:

This is really some additional help to an earlier thread that has provided almost what I want.
This thread:
VBA to extract data from multiple files in a folder

This is extracting the information almost as I want it. I have files in a folder, all have a similar format with the first 10 rows of each worksheet in the individual workbooks (they only have 1) having data that identifies where the data contained in row 11 onwards comes from.

What I would like to do is add the information held in Cell A8 and Cell D4 to the end of each row of the data that is extracted from that particular workbook and consolidated in the master as an identifier. It looks like the data copying over is done in one go and not line by line so I'm not sure how to go from here really. (sorry, a bit of a newbie)

The code I'm using adapted for my needs is:

Sub Consolidate()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder

Dim fName As String, fpath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet

'Setup
    Application.ScreenUpdating = False  'speed up macro execution
    Application.EnableEvents = False    'turn off other macros for now
    Application.DisplayAlerts = False   'turn off system messages for now
    
    Set wsMaster = ThisWorkbook.Sheets("Master")    'sheet report is built into

With wsMaster
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        Cells.Select
        Selection.UnMerge
        .UsedRange.Offset(1).EntireRow.Clear
        NR = 2
    Else
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data
    End If

'Path and filename (edit this section to suit)
    fpath = "C:\Consolidate\"   'remember final \ in this string
    
    fPathDone = fpath & "Imported\"     'remember final \ in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fpath & "*.xls*")        'listing of desired files, edit filter as desired

'Import a sheet from found files
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fpath & fName)  'Open file

        'This is the section to customize, replace with your own action code as needed
            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            Range("A11:A" & LR).EntireRow.Copy .Range("A" & NR)
            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
            Name fpath & fName As fPathDone & fName           'move file to IMPORTED folder
            fName = Dir                                       'ready next filename
            
        
            
        End If
    Loop
End With

Any help would be appreciated.

Thanks

 

[I_know_nuffin]

Hi

the below code does what you want

I tested this in a workbook with sheet4 as the master and sheet5 as the data

data was in cells A11 to Y20 and random text in Cells A8 and D4

step through using F8 to see how it works then add the relevant sections into your main routine

Sub partcode()


' below used to test
Dim wsMaster As Worksheet, wsdata As Worksheet, fname As String
Set wsMaster = ActiveWorkbook.Sheets("Sheet4")
Set wsdata = ActiveWorkbook.Sheets("Sheet5")
fname = "Somefile"



'add 2 variables to hold the 2 cell values
Dim CellA8 As String, CellD4 As String
'add NR1 variable rowcount (and LC for column count if needed)
Dim NR1 As Long, LC As Long

NR = wsMaster.Range("A" & wsMaster.Rows.Count).End(xlUp).Row + 1 ' Last row



    Do While Len(fname) > 0
'        If Fname <> ThisWorkbook.name Then              'don't reopen this file accidentally
'            Set wbData = Workbooks.Open(FPath & Fname)  'Open file
'
        ' Set variables to cell values
            CellA8 = wsdata.Range("A8").Value
            CellD4 = wsdata.Range("D4").Value
'
'        'This is the section to customize, replace with your own action code as needed
             lr = wsdata.Range("A" & wsdata.Rows.Count).End(xlUp).Row  'Find last row
             wsdata.Range("A11:A" & lr).EntireRow.Copy wsMaster.Range("A" & NR)
             'wbData.Close False                                'close file
            
         ' Do we know if the last column is always the same?
         ' if it is - say column Y then add to next 2 columns
        ' wsMaster.Range("Z" & NR) = CellA8
        ' wsMaster.Range("AA" & NR) = CellD4
         
         ' or find last column
        LC = wsMaster.Cells(NR, wsMaster.Columns.Count).End(xlToLeft).Column
        Cells(NR, LC + 1) = CellA8
        Cells(NR, LC + 2) = CellD4
         
         
         ' set reference to start row
         NR1 = NR
            
            'NR = .Range("A" & .Rows.Count).End(xlUp).Row +1 'Next row
            NR = wsMaster.Range("A" & wsMaster.Rows.Count).End(xlUp).Row  ' Last row
            
        'Copy  value CellA8 down all rows
        
        'wsMaster.Range("Z" & NR1 & ":Z" & NR).Value = Range("Z" & NR1)
        'or if using LC
        wsMaster.Range(Cells(NR1, LC + 1), Cells(NR, LC + 1)).Value = wsMaster.Cells(NR1, LC + 1)
        
        'Copy  value CellD4 down all rows
        'wsMaster.Range("AA" & NR1 & ":AA" & NR).Value = Range("AA" & NR1)
        'or if using LC
        wsMaster.Range(Cells(NR1, LC + 2), Cells(NR, LC + 2)).Value = wsMaster.Cells(NR1, LC + 2)
        
        'Set NR to point to next row
        NR = NR + 1
            
'            Name FPath & Fname As fPathDone & Fname           'move file to IMPORTED folder
'            Fname = Dir                                       'ready next filename
            
        
            
'        End If
stop ' used to break the loop
    Loop

End Sub

 

[John_w]

What I would like to do is add the information held in Cell A8 and Cell D4 to the end of each row of the data that is extracted from that particular workbook

Untested, after the EntireRow.Copy:

            Dim LC As Long
            LC =  Cells(11, Columns.Count).End(xlToLeft).Column
            Range("A8").Copy .Cells(NR, LC+1).Resize(LR-11+1)
            Range("D4").Copy .Cells(NR, LC+2).Resize(LR-11+1)