VBA Condense Code and Loop Help

TheCobbler

New Member
Joined
Aug 21, 2021
Messages
29
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

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
65,587
Office Version
  1. 365
Platform
  1. Windows
Are Active, Bar &Cia, on there own in the cell, or part of a larger string?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
65,587
Office Version
  1. 365
Platform
  1. Windows
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
 

TheCobbler

New Member
Joined
Aug 21, 2021
Messages
29
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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) <<<<<<<
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
65,587
Office Version
  1. 365
Platform
  1. Windows
Oops, forgot to add the sheet reference. What is the name of the sheet the data should be copied to?
 

TheCobbler

New Member
Joined
Aug 21, 2021
Messages
29
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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:
Solution

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
65,587
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

TheCobbler

New Member
Joined
Aug 21, 2021
Messages
29
Office Version
  1. 365
Platform
  1. Windows
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")
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
65,587
Office Version
  1. 365
Platform
  1. Windows
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)
 

Forum statistics

Threads
1,147,476
Messages
5,741,351
Members
423,657
Latest member
Medrok2021

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