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

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA Code:
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
 

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
Read again posts #2, #5 and #18 - but well this time - and do the necessary, no difficulty, kid level …​
If really there is an issue, post at least your new entire code attempt - so obviously not like in post #15 ‼ - in order any helper can see where you failed / misread​
rather than trying to guess anything …​
See here below is the new code pls check it. Bold Line of VBA code is giving error.

VBA Code:
Sub LoopxlsFiles()
    Dim sFile           As String
    Dim Wb              As Workbook
    Dim sPath           As String
    sPath = "C:\Users\Doll5\OneDrive\Desktop\Wages" '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
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 ActiveWorkbook.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
  [B]uba2 = UBound(a, 2)[/B]
  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
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,612
Office Version
  1. 2010
Platform
  1. Windows
Again a guessing challenge ‼​
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,612
Office Version
  1. 2010
Platform
  1. Windows
According to your 'so helpful accurate & complete' post #21 :rolleyes: I guess the issue comes from your data​
so to check according to the codeline and its error code, error message and error help …​
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,612
Office Version
  1. 2010
Platform
  1. Windows
As your error has nothing to do with the purpose of this thread well solved with posts #2 & #5​
so the better is to create a new thread at the level of what any forum expects for (accurate, complete, crystal clear, with an attachment, …)​
in order there is nothing to guess so you will get a solution in next post …​
 

Navi_G

Board Regular
Joined
May 30, 2018
Messages
94
Office Version
  1. 2016
Platform
  1. Windows
As your error has nothing to do with the purpose of this thread well solved with posts #2 & #5​
so the better is to create a new thread at the level of what any forum expects for (accurate, complete, crystal clear, with an attachment, …)​
in order there is nothing to guess so you will get a solution in next post …​
Ok thanks for giving your time.
 

Forum statistics

Threads
1,144,389
Messages
5,724,073
Members
422,534
Latest member
ThiccNugg

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top