Need my macro to look at every worksheet in source workbooks and return data to destination workbook

[sspatriots]

Hi,

Right now this code will only look at the worksheet named "DEM Release Form" in the source workbook. I've learned that in many instances, the user has copied this worksheet and made several more in the same workbook using different names. I need to be able to loop through each worksheet and pull the data into my destination workbook. I tried several attempts with other code I found online, but nothing would work because of this "Do" and "Loop" already in this code. Any help would be greatly appreciated. I feel pretty good that I was able to make the other two issues I ran into work on my own, but this one has me stumped.


Thanks, SS

Sub ImportInfo()
    Dim sPath As String 'path of folder containing info
    Dim sFileName As String '
    Dim wsSummary As Worksheet 'worksheet to paste data to in this workbook
    Dim wsData As Worksheet 'sheet with data to copy
    Dim wb As Workbook 'workbooks to loop thorugh
    Dim nr As Long 'next row to add the data
    Dim cbValue As Variant
    
    'Get the worksheet to add the info to
    Set wsSummary = ThisWorkbook.Worksheets("Sheet1")
    
        
    'first row is 2
    nr = 2
    
    sPath = "C:\Users\SShockley\OneDrive - Delaware Elevator\Documents\FACTORY RELEASE FORMS\" '[COLOR=#ff0000][B]Change as required[/B][/COLOR]
    
    sFileName = Dir(sPath & "*.xlsm")
    
    
    Application.ScreenUpdating = False
    
    
    Do While sFileName <> ""
        'open workbook
        Set wb = Workbooks.Open(Filename:=sPath & sFileName, ReadOnly:=True)
        'get the sheet to copy from
        
        
        Set wsData = wb.Sheets("DEM Release Form")
        'get the data
        
        wsSummary.Range("A" & nr).Value = wsData.Range("C3").Value
        wsSummary.Range("B" & nr).Value = wsData.Range("C4").Value
        wsSummary.Range("C" & nr).Value = wsData.Range("H4").Value
        wsSummary.Range("D" & nr).Value = wsData.Range("B8").Value
        wsSummary.Range("E" & nr).Value = wsData.Range("F8").Value
        wsSummary.Range("F" & nr).Value = wsData.Range("C10").Value
        wsSummary.Range("G" & nr).Value = wsData.Range("G10").Value
        wsSummary.Range("H" & nr).Value = wsData.Range("B9").Value
        wsSummary.Range("I" & nr).Value = wsData.Range("I9").Value
        
    
    If cbValue = ActiveSheet.OLEObjects("CheckBox1").Object.Value = "True" Then
        
        wsSummary.Range("K" & nr).Value = "YES"
        
    Else
            
        wsSummary.Range("K" & nr).Value = ""

    End If
        
        
    If cbValue = ActiveSheet.OLEObjects("CheckBox2").Object.Value = "True" Then
        
        wsSummary.Range("J" & nr).Value = "YES"
        
    Else
            
        wsSummary.Range("J" & nr).Value = ""

        
    End If
        
     
        'get next row
        nr = nr + 1
        'close the workbook
        wb.Close
        'get next workbook name
        sFileName = Dir
    
    
    Loop
    
    
    Application.ScreenUpdating = True
    
    
    
End Sub

 

[dmt32]

Hi,
untested but see if this update to your code does what you want

Sub ImportInfo()
    Dim sPath       As String           'path of folder containing info
    Dim sFileName   As String           '
    Dim wsSummary   As Worksheet        'worksheet to paste data to in this workbook
    Dim ws          As Worksheet        'sheets with data to copy
    Dim wb          As Workbook         'workbooks to loop thorugh
    Dim nr          As Long             'next row to add the data
    
    'Get the worksheet to add the info to
    Set wsSummary = ThisWorkbook.Worksheets("Sheet1")
    
    'first row is 2
    nr = 2
    
    sPath = "C:\Users\SShockley\OneDrive - Delaware Elevator\Documents\FACTORY RELEASE FORMS\"
    
    sFileName = Dir(sPath & "*.xlsm")
    
    Application.ScreenUpdating = False
    
    Do While sFileName <> ""
        'open workbook
        Set wb = Workbooks.Open(FileName:=sPath & sFileName, ReadOnly:=True)
        
        'get the data
        
        'get each sheet to copy from
        For Each ws In wb.Worksheets
            
            wsSummary.Range("A" & nr).Value = ws.Range("C3").Value
            wsSummary.Range("B" & nr).Value = ws.Range("C4").Value
            wsSummary.Range("C" & nr).Value = ws.Range("H4").Value
            wsSummary.Range("D" & nr).Value = ws.Range("B8").Value
            wsSummary.Range("E" & nr).Value = ws.Range("F8").Value
            wsSummary.Range("F" & nr).Value = ws.Range("C10").Value
            wsSummary.Range("G" & nr).Value = ws.Range("G10").Value
            wsSummary.Range("H" & nr).Value = ws.Range("B9").Value
            wsSummary.Range("I" & nr).Value = ws.Range("I9").Value
            wsSummary.Range("J" & nr).Value = IIf(ws.OLEObjects("CheckBox2").Object.Value, "YES", "")
            wsSummary.Range("K" & nr).Value = IIf(ws.OLEObjects("CheckBox1").Object.Value, "YES", "")
            
            'get next row
            nr = nr + 1
        Next ws
        
        'close the workbook
        wb.Close False
        'get next workbook name
        sFileName = Dir
        
        Set wb = Nothing
        
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

It is assumed in making copies of the sheet that your users have retained the CheckBox controls with same name

Dave

 

[sspatriots]

Worked great. Thank you so much

 

[dmt32]

Worked great. Thank you so much

most welcome & appreciate the feedback

Dave