To Open only .Xls* files and copy particular cells

[GirishDhruva]

Hi Everyone,

I am trying to copy particular cell values from all the excel files in a particular folder

Here Master sheet is the main sheet in which i need to copy the values from other excel files
Here is my requirements,

1.I need to search for all the Excel files in a particular folder
2.From that folder from each excel files i need to copy
D4 and paste in master sheet cells A
D5 and paste in master sheet cells B
F14:F19 and paste(transpose) in cells C:H

I have the code but in this i have 2 errors which i couldn't solve

Errors which i am facing
1.I couldn't paste the values of Highlighted cells from all the excel files
2.It is taking more time where if i have more than 100 files, their is changes for excel to go to "Not Responding" State

Option Explicit


Sub LoopThroughFiles()


Dim MyObj As Object, MySource As Object


Dim file, Folder, Fname As Variant
Dim wbThis                  As Workbook
Dim wbTarget                As Workbook
Dim LastRow As Long
Dim sht1 As Worksheet
Dim sht2 As Worksheet


Dim vDB, vDB1, vDB2, vDB3, vDB4, vDB5, vDB6, vDB7 As Variant


Set wbThis = ActiveWorkbook
Set sht1 = wbThis.Sheets("Sheet1")


Folder = Cells(2, "J").Value & "\"
Fname = Dir(Folder & "*.xls*")


While (Fname <> "")


  Set wbTarget = Workbooks.Open(Filename:=Folder & Fname)


  vDB = wbTarget.Sheets(1).Range("D4")
  vDB1 = wbTarget.Sheets(1).Range("D5")
  vDB2 = wbTarget.Sheets(1).Range("F14")
  vDB3 = wbTarget.Sheets(1).Range("F15")
  vDB4 = wbTarget.Sheets(1).Range("F16")
  vDB5 = wbTarget.Sheets(1).Range("F17")
  vDB6 = wbTarget.Sheets(1).Range("F18")
  vDB7 = wbTarget.Sheets(1).Range("F19")
    
        sht1.Range("A" & Rows.Count).End(xlUp)(2) = vDB
        sht1.Range("B" & Rows.Count).End(xlUp)(2) = vDB1
        sht1.Range("C" & Rows.Count).End(xlUp)(2) = vDB2
        sht1.Range("D" & Rows.Count).End(xlUp)(2) = vDB3
        sht1.Range("E" & Rows.Count).End(xlUp)(2) = vDB4
        sht1.Range("F" & Rows.Count).End(xlUp)(2) = vDB5
        sht1.Range("G" & Rows.Count).End(xlUp)(2) = vDB6
        sht1.Range("H" & Rows.Count).End(xlUp)(2) = vDB7


 Fname = Dir




  wbTarget.Close
 Wend


End Sub

Below is the excel File
https://app.box.com/s/cflde3s87qkj11c69vyfv0h5ur9n4bpq

Any suggestions/Solutions could help me a lot

Regards
Dhruva

 

[dmt32]

Hi,
looping 100+ files likely not to be a quick process but see if this update to your code is of any help to you

Sub LoopThroughFiles()
    Dim FolderName As Variant, FileName As Variant
    Dim wbTarget As Workbook
    Dim sht1 As Worksheet
    Dim arr(1 To 8) As Variant
    Dim cell As Range
    Dim i As Integer
    
    Set sht1 = ThisWorkbook.Worksheets("Sheet1")
    
    FolderName = sht1.Cells(2, "J").Value & "\"
    FileName = Dir(FolderName & "*.xls*")
    
    Application.ScreenUpdating = False
    While FileName <> ""
        
        Set wbTarget = Workbooks.Open(FileName:=FolderName & FileName, UpdateLinks:=False, ReadOnly:=True)
        i = 1
        For Each cell In wbTarget.Sheets(1).Range("D4:D5,F14:F19").Cells
            arr(i) = cell.Value
            i = i + 1
        Next cell
            
        With sht1
            .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 1).Resize(, UBound(arr)).Value = arr
        End With
            
        wbTarget.Close False
        Set wbTarget = Nothing
        Erase arr
        
        FileName = Dir
    Wend
    Application.ScreenUpdating = True
End Sub

Note the range where your folder name is specified (shown in red) was unqualified. I assumed that range is on sheet1 and qualified to this but if this is not correct then update as required.


Dave

 

[GirishDhruva]

Thanks @dmt32 it works perfectly but if any cell values is found blank means can we update that with 0 in D4:D5,F14:F19

 

[dmt32]

Thanks @dmt32 it works perfectly but if any cell values is found blank means can we update that with 0 in D4:D5,F14:F19

Hi,
glad solution helped

To amend code as requested

replace this line

arr(i) = cell.Value

with this

arr(i) = IIf(Len(cell.Value) = 0, 0, cell.Value)

Dave

 

[GirishDhruva]

Thank Dave

 

[dmt32]

Thank Dave

welcome - thanks for feedback

Dave