VBA Condense Code and Loop Help

TheCobbler

New Member
Joined
Aug 21, 2021
Messages
49
Office Version
  1. 365
Platform
  1. Windows
Hi again! Close to the point of giving up here and just doing things the long way. Rather than repeating the code I want to change my variables with a Loop. I've got around 14 books and different values that I want to open and copy data to based on a value in Column E. As below, If Column E contains 'ACTIVE' Then copy it to Workbook with "Path A", then If E contains BAR copy it to "Path B" etc. Any help much appreciated. Thanks!

VBA Code:
Option Explicit

Sub LoopHelp()

    Application.ScreenUpdating = False
    
    Dim Lastrow, NextRow, ThisValue As Variant
    Dim X As Integer
    Dim ThisWb, WbkA, WbkB, WbkC As Workbook
    
    Set ThisWb = ThisWorkbook
    Set WbkA = Workbooks.Open("C:\Users\Desktop\Array Test\Path A.xlsx")
    Set WbkB = Workbooks.Open("C:\Users\Desktop\Array Test\Path B.xlsx")
    Set WbkC = Workbooks.Open("C:\Users\Desktop\Array Test\Path C.xlsx")
    
            ThisWb.Activate
            Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
            For X = 2 To Lastrow
                ThisValue = Cells(X, 5).Value
                
                    If InStr(1, ThisValue, "ACTIVE") > 0 Then
                        Cells(X, 1).Resize(1, 33).Copy
                        WbkA.Activate
                        NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
                        Cells(NextRow, 1).Select
                        ActiveSheet.Paste
                        ThisWorkbook.Activate

                    End If
                Next X

            ThisWb.Activate
            Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
            For X = 2 To Lastrow
                ThisValue = Cells(X, 5).Value
                
                    If InStr(1, ThisValue, "BAR") > 0 Then
                        Cells(X, 1).Resize(1, 33).Copy
                        WbkB.Activate
                        NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
                        Cells(NextRow, 1).Select
                        ActiveSheet.Paste
                        ThisWorkbook.Activate

                    End If
                Next X
                
            ThisWb.Activate
            Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
            For X = 2 To Lastrow
                ThisValue = Cells(X, 5).Value
                
                    If InStr(1, ThisValue, "CIA") > 0 Then
                        Cells(X, 1).Resize(1, 33).Copy
                        WbkC.Activate
                        NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
                        Cells(NextRow, 1).Select
                        ActiveSheet.Paste
                        ThisWorkbook.Activate

                    End If
                Next X

    WbkA.Close True
    WbkB.Close True
    WbkC.Close True
    
    Application.ScreenUpdating = True

End Sub
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Are Active, Bar &Cia, on there own in the cell, or part of a larger string?
 
Upvote 0
Ok, how about
VBA Code:
Sub LoopHelp()
   
   Application.ScreenUpdating = False
   
   Dim Lastrow, NextRow, ThisValue As Variant
   Dim X As Integer
   Dim ThisWb, WbkA, WbkB, WbkC As Workbook
   
   Set ThisWb = ThisWorkbook
   Set WbkA = Workbooks.Open("C:\Users\Desktop\Array Test\Path A.xlsx")
   Set WbkB = Workbooks.Open("C:\Users\Desktop\Array Test\Path B.xlsx")
   Set WbkC = Workbooks.Open("C:\Users\Desktop\Array Test\Path C.xlsx")
   
   ThisWb.Activate
   Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
   For X = 2 To Lastrow
      Select Case Cells(X, 5).Value
         Case "ACTIVE"
            Cells(X, 1).Resize(1, 33).Copy WbkA.Range("A" & Rows.Count).End(xlUp).Offset(1)
         Case "BAR"
            Cells(X, 1).Resize(1, 33).Copy WbkB.Range("A" & Rows.Count).End(xlUp).Offset(1)
         Case "CIA"
            Cells(X, 1).Resize(1, 33).Copy WbkC.Range("A" & Rows.Count).End(xlUp).Offset(1)
      End Select
   Next X
   
   WbkA.Close True
   WbkB.Close True
   WbkC.Close True
   
   Application.ScreenUpdating = True
   
End Sub
 
Upvote 0
Getting "runtime error 438" on this line.

Case "ACTIVE"
Cells(X, 1).Resize(1, 33).Copy WbkA.Range("A" & Rows.Count).End(xlUp).Offset(1) <<<<<<<
 
Upvote 0
Oops, forgot to add the sheet reference. What is the name of the sheet the data should be copied to?
 
Upvote 0
Oops, forgot to add the sheet reference. What is the name of the sheet the data should be copied to?
Aha! Of course. I've popped them in as Sheets(1) for now as I'll need to double check. Works perfectly - Thanks once again for your help! :)

VBA Code:
Option Explicit

Sub LoopHelp()
  
   Application.ScreenUpdating = False
  
   Dim Lastrow, NextRow, ThisValue As Variant
   Dim X As Integer
   Dim ThisWb, WbkA, WbkB, WbkC As Workbook
  
   Set ThisWb = ThisWorkbook
   Set WbkA = Workbooks.Open("C:\Users\Username\Desktop\Array Test\Path A.xlsx")
   Set WbkB = Workbooks.Open("C:\Users\Username\Desktop\Array Test\Path B.xlsx")
   Set WbkC = Workbooks.Open("C:\Users\Username\Desktop\Array Test\Path C.xlsx")
  
   ThisWb.Activate
   Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
   For X = 2 To Lastrow
      Select Case Cells(X, 5).Value
         Case "ACTIVE"
            Cells(X, 1).Resize(1, 33).Copy WbkA.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
         Case "CARGO"
            Cells(X, 1).Resize(1, 33).Copy WbkB.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
         Case "PIAS"
            Cells(X, 1).Resize(1, 33).Copy WbkC.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
      End Select
   Next X
  
   WbkA.Close True
   WbkB.Close True
   WbkC.Close True
  
   Application.ScreenUpdating = True
  
End Sub
 
Last edited by a moderator:
Upvote 0
Solution
You're welcome & thanks for the feedback.
I've just spent some time updating my code and had an error occur in the same place. It seems that if the destination book is .xlsx it works fine. If it's .xls the error occurs. If possible could you help me understand why? Cheers, Cobb

VBA Code:
    Set WbkA = Workbooks.Open("C:\Users\Username\Desktop\Array Test\Path A.xlsx")
    Set WbkB = Workbooks.Open("C:\Users\Username\Desktop\Array Test\Path B.xls")
 
Upvote 0
You will need to do
VBA Code:
Cells(X, 1).Resize(1, 33).Copy WbkA.Sheets(1).Range("A" & WbkA.Sheets(1).Rows.Count).End(xlUp).Offset(1)
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,185
Members
448,554
Latest member
Gleisner2

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
Back
Top