Can Anyone Help Amending This Code?

[Delta Star]

I've found the code below which loops through a directory and copies data from cell K2 into a summary sheet.

I need it to be amended so that cells K2, L7 and G6 are copied into the summary sheet into adjoining cells.

Can anyone help with this?

Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\Volumes"
.FileType = msoFileTypeExcelWorkbooks
'.Filename = "Book*.xls"
If .Execute > 0 Then 'Workbooks in folder
    For lCount = 1 To .FoundFiles.Count 'Loop through all.
    'Open Workbook x and Set a Workbook variable to it
        Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
        'DO YOUR CODE HERE
        
        wbResults.Worksheets("Volume Data").Range("K2").Copy
        wbCodeBook.Worksheets("Sheet1").Range("A" & wbCodeBook.Worksheets("Sheet1").Range("A65536").End(xlUp).Row).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, _
                            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
        wbResults.Close SaveChanges:=False
    
    Next lCount
    
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

 

[Delta Star]

Anyone able to assist?

 

[ukmikeb]

Hi

Try (untested) -

Dim wbCBSh1LR as Long
wbCBSh1LR=  wbCodeBook.Worksheets("Sheet1").Range("A65536").End(xlUp).Row
       wbResults.Worksheets("Volume Data").Range("L7").Copy
        wbCodeBook.Worksheets("Sheet1").Range("B" & wbCBSh1LR).PasteSpecial Paste:=xlPasteValues, _
                            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        wbResults.Worksheets("Volume Data").Range("G6").Copy
        wbCodeBook.Worksheets("Sheet1").Range("C" & wbCBSh1LR).PasteSpecial Paste:=xlPasteValues, _
                            Operation:=xlNone, SkipBlanks:=False, Transpose:=False

which should copy those fields into the row you've just created while copying cell K2.

hth

 

[Norie]

Try this, it uses Dir because in Application.FileSearch isn't available in later versions of Excel.

Option Explicit
 
Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim wsData As Worksheet
Dim wsDst As Worksheet
Dim rngSrc As Range
Dim rngDst As Range
Dim strPath As String
Dim strFileExt As String
Dim strFileName As String
Dim I As Long
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wbCodeBook = ThisWorkbook
 
    Set wsDst = wbCodeBook.Worksheets("Sheet1")
 
    Set rngDst = wsDst.Range("A" & Rows.Count).End(xlUp).Offset(1)
 
    strPath = "C:\Test\"
 
    strFileExt = "xls?"
 
    strFileName = Dir(strPath & "*." & strFileExt)
 
    While strFileName <> ""
 
        If strFileName <> wbCodeBook.Name Then

            Set wbResults = Workbooks.Open(strPath & strFileName)
 
            Set wsData = wbResults.Worksheets("Volume Data")
 
            Set rngSrc = wsData.Range("K2, L7, G6")
 
            For I = 1 To rngSrc.Areas.Count
                rngDst.Offset(, I - 1).Value = rngSrc.Areas(I).Value
            Next I
 
            wbResults.Close SaveChanges:=False
 
            Set rngDst = rngDst.Offset(1)
        End If

        strFileName = Dir()
 
    Wend
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
End Sub

 

[Delta Star]

Norie, thanks for the suggestion about application.filesearch.

I have come across a problem if a file does not contain the appropriate sheet name it causes the code to stop. Is it possible to amend so that if the sheet does not exist it moves onto the next file in the folder?

 

[Norie]

You could add the On Error back in.

That could actually hide other errors though.

If you search the board you'll find functions you can use to check for a sheet with a certain name.

Here's one.

Function IsSheetReal(strSheetName As String, wb As Worbook) As Boolean
Dim ws As Sheet 
    
    For Each ws In wb.Sheets 

           If ws.Name =  strSheetName Then 
                IsSheetReal = True   

                Exit For

           End If 

     Next ws

End Function

You could use that like after you open each file like this perhaps.

If IsSheetReal("Volume Data", wbResults) Then

      ' code to copy data
End If

' close workbook and continue with code

That's kind of untested but hopefully you get the idea.

You'll probably find something better if you search.