Simplyfying My Macro

[ian0886]

Hi All,

I currently have a VBA code that works fine. But i find it too lengthy and wish to shorten it for tidiness sake.

strFile1 = "Z:\tickets\" & "BNPLDN" & ".xls"

 'Workbooks("Fx_Activity.csv").Activate    'Range("a1").Select
    'Selection.AutoFilter
    'Selection.AutoFilter Field:=rng1.Column, Criteria1:="LDN"
    
    'Set wbO = Workbooks.Add
    'Worksheets(1).Select
    'Worksheets(1).Name = "Hello"
    'Application.DisplayAlerts = False
    
    'With wbO
    'Set wsO = wbO.Sheets("Hello")
    '.SaveAs Filename:=strFile, FileFormat _
    ':=xlExcel8, CreateBackup:=False
    'wsI.Range("a1").CurrentRegion.Copy
    'wsO.Range("a1").PasteSpecial xlPasteAll, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    '.Save
    'End With

I've tried doing a For Next statement but i'm having little success.

    SearchCol = "Portfolio"    Dim rng1 As Range
    Set rng1 = ActiveSheet.UsedRange.Find(SearchCol, , xlValues, xlWhole)
    
    Dim wbI As Workbook, wbO1 As Workbook, wbO2 As Workbook, wbO3 As Workbook, wbO4 As Workbook, wbO5 As Workbook
    Dim wsI As Worksheet, wsO1 As Worksheet, wsO2 As Worksheet, wsO3 As Worksheet, wsO4 As Worksheet, wsO5 As Worksheet
    Dim strFile1 As String, strFile2 As String, strFile3 As String, strFile4 As String, strFile5 As String
    
    strFile1 = "Z:\tickets\" & "BNPLDN" & ".xls"
    strFile2 = "Z:\tickets\" & "BNPTKY" & ".xls"
    strFile3 = "Z:\tickets\" & "BNPNY4" & ".xls"
    strFile4 = "Z:\tickets\" & "BNPPOPNY4" & ".xls"
    strFile5 = "Z:\tickets\" & "BNPPOPSWOP" & ".xls"
    
    Dim c1 As Range, c2 As Range, c3 As Range, c4 As Range, c5 As Range
    c1 = "(LDN)"
    c2 = "(TKY)"
    c3 = "(NY4)"
    c4 = "LC (NY4)"
    c5 = "Swap"
    
    Set wbI = ActiveWorkbook
    Set wsI = wbI.Sheets("Hello")
    
    Dim counter As Integer
    For counter = 1 To 5
    
    Dim wbOcounter As Range, wsOcounter As Range, ccounter As Range
    
    
    Workbooks("Fx_Activity.csv").Activate
    Range("a1").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=rng1.Column, Criteria1:="ccounter"
    
    Set wbOcounter = Workbooks.Add
    Worksheets(1).Select
    Worksheets(1).Name = "BNP"
    Application.DisplayAlerts = False
    
    With wbOcounter
    Set wsOcounter = wbOcounter.Sheets("Hello")
    .SaveAs Filename:=strFile, FileFormat _
    :=xlExcel8, CreateBackup:=False
    wsI.Range("a1").CurrentRegion.Copy
    wsOcounter.Range("a1").PasteSpecial xlPasteAll, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    .Save
    End With
    Next

Can anyone kindly help me with this since i've just started writing my own codes.

 

[RoryA]

You need a couple of arrays but, as far as I can see, you don't need so many workbook or worksheet objects. Try something like this:

    SearchCol = "Portfolio"
    Dim rng1                  As Range
    Set rng1 = ActiveSheet.UsedRange.Find(SearchCol, , xlValues, xlWhole)

    Dim wbI                   As Workbook
    Dim wbO                   As Workbook
    Dim wsI                   As Worksheet
    Dim wsO                   As Worksheet
    Dim strFile(1 To 5)       As String

    strFile(1) = "Z:\tickets\" & "BNPLDN" & ".xls"
    strFile(2) = "Z:\tickets\" & "BNPTKY" & ".xls"
    strFile(3) = "Z:\tickets\" & "BNPNY4" & ".xls"
    strFile(4) = "Z:\tickets\" & "BNPPOPNY4" & ".xls"
    strFile(5) = "Z:\tickets\" & "BNPPOPSWOP" & ".xls"

    Dim c(1 To 5)             As String
    c(1) = "(LDN)"
    c(2) = "(TKY)"
    c(3) = "(NY4)"
    c(4) = "LC (NY4)"
    c(5) = "Swap"

    Set wbI = ActiveWorkbook
    Set wsI = wbI.Sheets("Hello")

    Dim counter               As Integer
    For counter = 1 To 5
        Workbooks("Fx_Activity.csv").Activate
        Range("a1").Select
        Selection.AutoFilter
        Selection.AutoFilter Field:=rng1.Column, Criteria1:=c(counter)

        Set wbO = Workbooks.Add
        With wbO
            .Worksheets(1).Select
            .Worksheets(1).Name = "BNP"
            Application.DisplayAlerts = False

            Set wsO = .Sheets("Hello")
            .SaveAs Filename:=strFile(counter), FileFormat:=xlExcel8, CreateBackup:=False
            wsI.Range("a1").CurrentRegion.Copy
            wsO.Range("a1").PasteSpecial xlPasteAll, Operation:=xlNone, _
                                         SkipBlanks:=False, Transpose:=False
            .Save
        End With
    Next

 

[ian0886]

thanks RoryA, it works perfectly!