Modifying code from Dave Brett - pulling data from closed workbooks into 1 workbook

I'm guessing this has probably been answered, but I can't find it anywhere.

I'm using code posted by Dave Brett in 2010 on how to copy sheets from multiple closed workbooks in a folder and paste them into 1 workbook (at end of this post).  I've been struggling for a while to figure out how to modify this code so that only 1 row of 1 sheet from each source wb is copied (instead of the entire wb).  I'm a complete VBA novice, and any little change I make seems to screw up parts of the code I don't understand enough to fix.  

My source wbs are all identical.  Sheet 1 - "Data Entry" - is formatted to look very pretty and is a place where lots of employees in my office enter data they collect from audit visits.  So row1 is a title, row 2 is a header, and ROW3 is where they enter the data.  Rows below that give space for them to write comments, etc.  Sheets 2 and 3 and 4 have other information.  After each audit visit, the employee data enters the audit results, saves the file with a new name, and puts it in the same folder with all the other completed workbooks.

I want to pull ROW3 only from sheet "Data Entry" only from all the files saved in the same folder.  Dave's code works brilliantly, except that I can't figure out how to copy only 1 row from 1 sheet instead of everything from the entire source workbooks.  

Any help greatly appreciated!  Any very sorry if this has been answered (perhaps multiple times) before.  I've found lots of codes that SEEM like they should answer this question, but nothing has worked until I found Dave's Code (and nothing I can find works to narrow down the copy/paste function).


Public Sub ConsolidateSheets()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rngArea As Range
    Dim lrowSpace As Long
    Dim lSht As Long
    Dim lngCalc As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim X()
    Dim bProcessFolder As Boolean
    Dim bNewSheet As Boolean

    Dim StrPrefix
    Dim strFileName As String
    Dim strFolderName As String

    'variant declaration needed for the Shell object to use a default directory
    Dim strDefaultFolder As Variant


 bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
    bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
    If Not bProcessFolder Then
        If Not bNewSheet Then
            MsgBox "There isn't much point creating a exact replica of your source file :)"
            Exit Sub
        End If
    End If

    'set default directory here if needed
    strDefaultFolder = "S:\AuditResults - save your excel files here"

    'If the user is collating all the sheets to a single target sheet then the row spacing
    'to distinguish between different sheets can be set here
    lrowSpace = 1

    If bProcessFolder Then
        strFolderName = BrowseForFolder(strDefaultFolder)
        'Look for xls, xlsx, xlsm files
        strFileName = Dir(strFolderName & "\*.xls*")
    Else
        strFileName = Application _
                      .GetOpenFilename("Select file to process (*.xls*), *.xls*")
    End If

    Set Wb1 = Workbooks.Add(1)
    Set ws1 = Wb1.Sheets(1)
    If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")

    'Turn off screenupdating, events, alerts and set calculation to manual
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    'set path outside the loop
    StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)

    Do While Len(strFileName) > 0
        'Provide progress status to user
        Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
        'Open each workbook in the folder of interest
        Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
        If Not bNewSheet Then
            'add summary details to first sheet
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
        End If
        For Each ws2 In Wb2.Sheets
            If bNewSheet Then
                'All data to a single sheet
                'Skip importing target sheet data if the source sheet is blank
                Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)

                If Not rng2 Is Nothing Then
                    Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
                    'Find the first blank row on the target sheet
                    If Not rng1 Is Nothing Then
                        Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
                        'Ensure that the row area in the target sheet won't be exceeded
                        If rng3.Rows.Count + rng1.Row < Rows.Count Then
                            'Copy the data from the used range of each source sheet to the first blank row
                            'of the target sheet, using the starting column address from the source sheet being copied
                            ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                        Else
                            MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
                                   "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
                            Wb2.Close False
                            Exit Do
                        End If
                        'colour the first of any spacer rows
                        If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
                    Else
                        'target sheet is empty so copy to first row
                        ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                    End If
                End If
            Else
                'new target sheet for each source sheet
                ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
                'Remove any links in our target sheet
                With Wb1.Sheets(Wb1.Sheets.Count).Cells
                    .Copy
                    .PasteSpecial xlPasteValues
                End With
                On Error Resume Next
                Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
                'sheet name already exists in target workbook
                If Err.Number <> 0 Then
                    'Add a number to the sheet name till a unique name is derived
                    Do
                        lSht = lSht + 1
                        Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                    Loop While Not ws3 Is Nothing
                    lSht = 0
                End If
                On Error GoTo 0
            End If
        Next ws2
        'Close the opened workbook
        Wb2.Close False
        'Check whether to force a DO loop exit if processing a single file
        If bProcessFolder = False Then Exit Do
        strFileName = Dir
    Loop

    'Remove any links if the user has used a target sheet
    If bNewSheet Then
        With ws1.UsedRange
            .Copy
            .Cells(1).PasteSpecial xlPasteValues
            .Cells(1).Activate
        End With
    Else
        'Format the summary sheet if the user has created separate target sheets
        ws1.Activate
        ws1.Range("A1:B1").Font.Bold = True
        ws1.Columns.AutoFit
    End If

    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = lngCalc
        .StatusBar = vbNullString
    End With
End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'From Ken Puls as used in his vbaexpress.com article
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284

    Dim ShellApp As Object
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.path
    On Error GoTo 0

    'Destroy the Shell Application
    Set ShellApp = Nothing

    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function
zalikAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

gowflowCommented:
Well not having posted your workbook as a sample so we can clearly identify what you need as a first guess it would be this row that need to be changed:

ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)

If you say it is Row3 that you need then replace it by this
ws2.Range("3:3").EntireRow.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)

and give it a shot will see from there on. I suspect if you only want 1 specific sheet then will need to do a screnning elsewhere as well but try this first and let's see where you end up with.
gowflow
zalikAuthor Commented:
Thank you.

The resulting workbook appears to have opened both source files, copied the entire sheet#1 from file#1 then rows3 from following sheets; and on source file #2 copied only row#3 from all 3 sheets.  Getting there?

I've attached here a basic sample of the source workbooks.  A lot won't make sense in this version, but the key thing is that row#3 on sheet#1 has all of the data I need.  The other pages and other rows are only for the use of the auditors.  What I need is shown in the sample destination workbook I attached.  I need to pull row#3 from sheet #1 from about 300 different files - all saved in the same folder and identical except for the data in that row (including sheet names, etc) to create 1 sheet with 300 rows - 1 from each file.

I've also attached the output I get from the original code (it copies and pastes all sheets, all rows, from all files), and when I amend the line as you recommended (it pastes file#1,sheet#2(all), sheet#2(row3), sheet#3(row3) and file#2 row#3 from all sheets.
Copy-of-Source-Workbook.xlsm
Sample-destination-workbook.xlsx
output-original.xlsx
Output-amendedline.xlsx
gowflowCommented:
ok lets do this
replace this line
ws2.Range("3:3").EntireRow.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)

Open in new window


By these
If ws2.Name = "Data Entry" then
       ws2.Range("3:3").EntireRow.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
Endif

Open in new window


gowflow

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

zalikAuthor Commented:
Ok.  For some reason, it still copies the entire first sheet of the first file, but then it goes through and adds only row 3 for all subsequent files.  I can work with that - easy enough to just add code to delete the specific rows being added on extra on the first file.

Can't thank you enough!
gowflowCommented:
You should not accept a solution unless it is 100% correct.

Try replacing this
 'target sheet is empty so copy to first row
 ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)

Open in new window


By this also
If ws2.Name = "Data Entry" then
       ws2.Range("3:3").EntireRow.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)

Open in new window


Let me know if it sixes it completely.
gowflow
zalikAuthor Commented:
So I deleted
ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)

Open in new window

and instead entered
  'target sheet is empty so copy to first row
                      If ws2.Name = "Data Entry" Then
                         ws2.Range("3:3").EntireRow.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)

Open in new window

It tells me "Next without for" and highlights the Next ws2:
        'target sheet is empty so copy to first row
                      If ws2.Name = "Data Entry" Then
                         ws2.Range("3:3").EntireRow.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                         
                        
                     '   ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                    End If
                End If
            Else
                'new target sheet for each source sheet
                ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
                'Remove any links in our target sheet
                With Wb1.Sheets(Wb1.Sheets.Count).Cells
                    .Copy
                    .PasteSpecial xlPasteValues
                End With
                On Error Resume Next
                Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
                'sheet name already exists in target workbook
                If Err.Number <> 0 Then
                    'Add a number to the sheet name till a unique name is derived
                    Do
                        lSht = lSht + 1
                        Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                    Loop While Not ws3 Is Nothing
                    lSht = 0
                End If
                On Error GoTo 0
            End If
        Next ws2

Open in new window




But I accepted the solution because I added
 '   Rows(4).EntireRow.Delete
 '   Rows(4).EntireRow.Delete
  '  Rows(4).EntireRow.Delete
  '  Rows(4).EntireRow.Delete
  '  Rows(4).EntireRow.Delete
  '  Rows(1).EntireRow.Delete

Open in new window

at the  end of the code, since it was only copying the entire sheet for file #1 and the sourcefiles are all identical.  Maybe not the most elegant solution, but I've tested it now with different numbers of source workbooks and it produces the exact result I was looking for every time (only row3 from each source file in the final sheet).
zalikAuthor Commented:
This is currently the full code:

Public Sub ConsolidateSheets()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rngArea As Range
    Dim lrowSpace As Long
    Dim lSht As Long
    Dim lngCalc As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim X()
    Dim bProcessFolder As Boolean
    Dim bNewSheet As Boolean

    Dim StrPrefix
    Dim strFileName As String
    Dim strFolderName As String

    'variant declaration needed for the Shell object to use a default directory
    Dim strDefaultFolder As Variant


 bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
    bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
    If Not bProcessFolder Then
        If Not bNewSheet Then
            MsgBox "There isn't much point creating a exact replica of your source file :)"
            Exit Sub
        End If
    End If

    'set default directory here if needed
    strDefaultFolder = "S:\AuditResults - save your excel files here"

    'If the user is collating all the sheets to a single target sheet then the row spacing
    'to distinguish between different sheets can be set here
 '   lrowSpace = 1

    If bProcessFolder Then
        strFolderName = BrowseForFolder(strDefaultFolder)
        'Look for xls, xlsx, xlsm files
        strFileName = Dir(strFolderName & "\*.xls*")
    Else
        strFileName = Application _
                      .GetOpenFilename("Select file to process (*.xls*), *.xls*")
    End If

    Set Wb1 = Workbooks.Add(1)
    Set ws1 = Wb1.Sheets(1)
    If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")

    'Turn off screenupdating, events, alerts and set calculation to manual
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    'set path outside the loop
    StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)

    Do While Len(strFileName) > 0
        'Provide progress status to user
        Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
        'Open each workbook in the folder of interest
        Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
        If Not bNewSheet Then
            'add summary details to first sheet
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
        End If
        For Each ws2 In Wb2.Sheets
            If bNewSheet Then
                'All data to a single sheet
                'Skip importing target sheet data if the source sheet is blank
                Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)

                If Not rng2 Is Nothing Then
                    Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
                    'Find the first blank row on the target sheet
                    If Not rng1 Is Nothing Then
                        Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
                        'Ensure that the row area in the target sheet won't be exceeded
                        If rng3.Rows.Count + rng1.Row < Rows.Count Then
                            'Copy the data from the used range of each source sheet to the first blank row
                            'of the target sheet, using the starting column address from the source sheet being copied
                            If ws2.Name = "Data Entry" Then
                              ws2.Range("3:3").EntireRow.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                        End If
                        Else
                            MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
                                   "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
                            Wb2.Close False
                            Exit Do
                        End If
                        'colour the first of any spacer rows
                        If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
                    Else
                        'target sheet is empty so copy to first row
                      If ws2.Name = "Data Entry" Then
                         ws2.Range("3:3").EntireRow.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                         
                        
                     '   ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                    End If
                End If
            Else
                'new target sheet for each source sheet
                ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
                'Remove any links in our target sheet
                With Wb1.Sheets(Wb1.Sheets.Count).Cells
                    .Copy
                    .PasteSpecial xlPasteValues
                End With
                On Error Resume Next
                Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
                'sheet name already exists in target workbook
                If Err.Number <> 0 Then
                    'Add a number to the sheet name till a unique name is derived
                    Do
                        lSht = lSht + 1
                        Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                    Loop While Not ws3 Is Nothing
                    lSht = 0
                End If
                On Error GoTo 0
            End If
        Next ws2
        'Close the opened workbook
        Wb2.Close False
        'Check whether to force a DO loop exit if processing a single file
        If bProcessFolder = False Then Exit Do
        strFileName = Dir
    Loop

    'Remove any links if the user has used a target sheet
    If bNewSheet Then
        With ws1.UsedRange
            .Copy
            .Cells(1).PasteSpecial xlPasteValues
            .Cells(1).Activate
        End With
    Else
        'Format the summary sheet if the user has created separate target sheets
        ws1.Activate
        ws1.Range("A1:B1").Font.Bold = True
        ws1.Columns.AutoFit
    End If
    
 '   Rows(4).EntireRow.Delete
 '   Rows(4).EntireRow.Delete
  '  Rows(4).EntireRow.Delete
  '  Rows(4).EntireRow.Delete
  '  Rows(4).EntireRow.Delete

    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = lngCalc
        .StatusBar = vbNullString
    End With
End Sub

Open in new window

gowflowCommented:
BIG SORRY MY MISTAKE

replace this:
If ws2.Name = "Data Entry" then
       ws2.Range("3:3").EntireRow.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)

Open in new window


BY THIS
If ws2.Name = "Data Entry" then
       ws2.Range("3:3").EntireRow.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
End if

Open in new window



It is missing the End if ... it messes up all the rest of the code Sorry for this stupid mistake !!!
gowflow
zalikAuthor Commented:
Aha!  THANKS!
gowflowCommented:
Did it work correctly ? Please remove the code you had put of delete or else you will be deleting other valuable lines !!!
gowlfow
zalikAuthor Commented:
It seems to be working fine.  And yes, thanks for the reminder to delete those lines!
gowflowCommented:
Great ! Enjoy

gowflow
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.