CODEWITHSUNDEEP
vbaexcel
user3045652
user3045652

Reputation: 39

To select only particular files from a folder using loop

I am trying to build a macro to collate information present in a particular folder but I need to select only the files which I have higlighted in particular row and collate the data in the adjacent column. Please help me in how I can I perform the task. I have written the basic syntax to open files and folder.

Private Sub CommandButton2_Click()
  Const FOLDER As String = "C:\SBI_FILES_1\"
  Const cStrWSName As String = "addl disclosures"
  Const cStrRangeAddress As String = "F30:F33"

Dim rngTarget As Range
Dim wbSource As Workbook

Dim fileName As String

On Error GoTo ErrorHandler

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set rngTarget = ThisWorkbook.Worksheets(cStrWSName).Range(cStrRangeAddress)

fileName = Dir(FOLDER, vbDirectory)
Do While Len(fileName) > 0

    If Right$(fileName, 4) = "xlsx" Or Right$(fileName, 3) = "xls" Then
     "I need to modify code here"
        Set wbSource = Workbooks.Open(FOLDER & fileName)

        wbSource.Worksheets(cStrWSName).Range(cStrRangeAddress).Copy
        rngTarget.PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd

        wbSource.Close
    End If
    fileName = Dir
Loop

ProgramExit:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
Exit Sub

ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description

    Resume ProgramExit
End Sub

Upvotes: 1

Views: 60

Answers (1)

Sathish Kothandam
Sathish Kothandam

Reputation: 1520

Let say you have file names in activesheet within a range *A2 to A10*

Private Sub CommandButton2_Click()
  Const FOLDER As String = "C:\SBI_FILES_1\"
  Const cStrWSName As String = "addl disclosures"
  Const cStrRangeAddress As String = "F30:F33"

Dim erange as range
Dim rng as range

Dim rngTarget As Range
Dim wbSource As Workbook

Dim fileName As String

On Error GoTo ErrorHandler

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

set rng = activesheet.range("A2:A10") ' filenames

Set rngTarget = ThisWorkbook.Worksheets(cStrWSName).Range(cStrRangeAddress)

fileName = Dir(FOLDER, vbDirectory)
Do While Len(fileName) > 0

    If Right$(fileName, 4) = "xlsx" Or Right$(fileName, 3) = "xls" Then


for each erange in rng


if instr(filename,erange.value) > 0 then ' checking file name whether its matches or not 

        Set wbSource = Workbooks.Open(FOLDER & fileName)

        wbSource.Worksheets(cStrWSName).Range(cStrRangeAddress).Copy
        rngTarget.PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd

        wbSource.Close

end if 

next erange




    End If
    fileName = Dir
Loop

ProgramExit:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
Exit Sub

ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description

    Resume ProgramExit
End Sub

Upvotes: 1

Related Questions