How to apply my VBA Code on multiple workbooks in a folder

[Navi_G]

Hi Experts,
I am here to find a help. I have a VBA code for my reports i want to apply this code on multiple workbooks in a folder at once is that possible if yes, pls provide a code i shall be very gratefull.

Sub RefineData3()
Dim i As Long, j As Long, Lr As Long, LrD As Long, N As Long, vWS As Worksheet, vR As Long
Dim a As Variant, b As Variant, k As Long, uba2 As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long, vA, vA2()
 Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
For i = 1 To ThisWorkbook.Sheets.Count - 1
If Sheets(i).Range("C20").Value = "TOTAL PCS" Then
Lr = Sheets(i).Range("D21").End(xlDown).Row
If Lr = Rows.Count Then GoTo Step2
Debug.Print Sheets(i).Name
LrD = Sheets("Result").Range("B" & Rows.Count).End(xlUp).Row + 1
If LrD = 2 Then
Sheets(i).Range("C17:AN" & Lr).Copy
Sheets("Result").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Sheets(i).Range("C21:AN" & Lr).Copy
Sheets("Result").Range("A" & LrD).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Step2:
End If
Next i
If Sheets("Result").Range("H4").Value = "" Then
Sheets("Result").Range("H4").Value = Sheets("Result").Range("G4").Value
Sheets("Result").Range("G4").Value = ""
End If
Sheets("Result").Rows("2:3").Delete
For i = 11 To 1 Step -1
  Select Case Trim(Sheets("Result").Cells(2, i).Value)
   Case "TOTAL PCS", "SHRINKAG", "Width", "Shade", "Balance", ""
    Sheets("Result").Columns(i).Delete
   End Select
Next i
With Sheets("Result")
.Range("D2:AN2").Value = .Range("D1:AN1").Value
.Rows("1").Delete
LrD = .Range("B" & Rows.Count).End(xlUp).Row
  .Range("A1:AN" & LrD).AutoFilter Field:=3, Criteria1:="<>"
  .Range("A1:AN" & LrD).SpecialCells(xlCellTypeVisible).Copy
  .Range("A" & LrD + 1).Select
   ActiveSheet.Paste
  .Range("A1:AN" & LrD).AutoFilter
  .Rows("1:" & LrD).Delete
  .Columns(3).Delete
  
  a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a) * (uba2 - 2), 1 To 4)
  For i = 2 To UBound(a)
    For j = 3 To uba2
      If Len(a(i, j)) > 0 Then
        k = k + 1
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, 2)
        b(k, 3) = a(1, j)
        b(k, 4) = a(i, j)
      End If
    Next j
  Next i
  Lr = .Range("A" & Rows.Count).End(xlUp).Row
  LrD = .Cells(1, Columns.Count).End(xlToLeft).Column
  Range(.Cells(1, 1), .Cells(Lr, LrD)).ClearContents
  .Range("A" & Rows.Count).End(xlUp).Resize(, 4).Value = Array("QTY", "CUT #", "Size", "Bundle")
  .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k, 4).Value = b
    
    vR = .Cells(Rows.Count, 4).End(xlUp).Row
    vSum = Application.Sum(.Range("D2:D" & vR))
     ReDim Preserve vA2(1 To vSum, 1 To 4)
    vA = .Range("A2:D" & vR)
      For vN = 1 To vR - 1
        For vN2 = 1 To vA(vN, 4)
          vC = vC + 1
           For vN3 = 1 To 4
             vA2(vC, vN3) = vA(vN, vN3)
           Next vN3
        Next vN2
      Next vN
 End With
       
  vC = 1
   For vN = 1 To vSum - 2
    vA2(vN, 4) = vC
     If vA2(vN + 1, 2) = vA2(vN, 2) Then
      vC = vC + 1
      vA2(vN + 1, 4) = vC
     Else
      vA2(vN + 1, 4) = 1
      vC = 1
     End If
   Next vN
 Sheets.Add(After:=Sheets(Sheets.Count)).Name = "FinalResult"
   With ActiveSheet
        Sheets("Result").Range("A1:D1").Copy .Range("A1:D1")
       .Cells(2, 1).Resize(vSum, 4) = vA2
  End With
Application.ScreenUpdating = True
End Sub

 

[vds1]

You need to paste the below code on top of your existing code. Please change the path and save changes accordingly as mentioned below.

Sub LoopxlsFiles()
    Dim sFile           As String
    Dim Wb              As Workbook
    Dim sPath           As String
    sPath = "C:\myfolder\" 'mention Full Path here
    sFile = Dir(sPath & "*.xls*")
    Do While Len(sFile) > 0
        Set Wb = Workbooks.Open(sPath & sFile)
        Call RefineData3
        Wb.Close True 'Make it false to omit changes
        Set Wb = Nothing
        sFile = Dir
    Loop
End Sub

 

[Navi_G]

Dear Sir,
I do it as per your instructions but is not working

 

[Navi_G]

Pls check this on following folder. My code is working separately but when I combine the both codes my code is also not working

Cut Detail - Google Drive

 

[vds1]

You need to open a fresh workbook and save the code in that workbook. Please save the file as xlsm format. Also change the below code in your refinedata3 procedure.

ThisWorkbook.Sheets.Count

to

Activeworkbook.sheets.count

 

[Navi_G]

You need to open a fresh workbook and save the code in that workbook. Please save the file as xlsm format. Also change the below code in your refinedata3 procedure.

ThisWorkbook.Sheets.Count

to

Activeworkbook.sheets.count

Only VBA file should be in xlsm or all sheets in folder???

 

[vds1]

Just the vba code should be in xlsm file.

 

[Navi_G]

Just the vba code should be in xlsm file.

I try this but not working

 

[Navi_G]

Dear experts
Given code is not working is there any other solution for my thread??? Plz do a a help.

 

[Marc L]

Hi,​

​

maybe tomorrow once free time to check if you have committed again a wild cross posting …​

​

Or the faster way like any forum expects in the initial post :​

• post at least each link to each other forum where you have created the same thread - you must do the same on every forum -​

• well elaborate your need in order there is nothing to guess as after all Excel forums are not mind readers forums​

• post an accurate attachment well reflecting the before state and the expected result accordingly …​