Is there a way to make this array code more concise?

D

Darranimo

Board Regular
Joined
Jan 19, 2022
Messages
52
Office Version
  1. 365
Platform
  1. Windows
VBA Code: 
Sub Dispatch()

rng = shtWF.cells(1, 1).CurrentRegion
rprw1 = sht1500.cells(Rows.Count, "A").End(xlUp).Row + 1
rprw2 = sht3480.cells(Rows.Count, "A").End(xlUp).Row + 1
rprw3 = sht2958.cells(Rows.Count, "A").End(xlUp).Row + 1
rprw4 = sht2966.cells(Rows.Count, "A").End(xlUp).Row + 1
rprw5 = sht2990.cells(Rows.Count, "A").End(xlUp).Row + 1
rprw6 = sht9111.cells(Rows.Count, "A").End(xlUp).Row + 1
rprw7 = sht9129.cells(Rows.Count, "A").End(xlUp).Row + 1

For rw = 1 To UBound(rng)
    If Right(rng(rw, 6), 4) = "1500" Then
        For cl = 1 To UBound(rng, 2)
            sht1500.cells(rprw1, cl) = rng(rw, cl)
        Next
        rprw1 = rprw1 + 1
    End If
    If Right(rng(rw, 6), 4) = "3480" Then
        For cl = 1 To UBound(rng, 2)
            sht3480.cells(rprw2, cl) = rng(rw, cl)
        Next
        rprw2 = rprw2 + 1
    End If
    If Right(rng(rw, 6), 4) = "2958" Then
        For cl = 1 To UBound(rng, 2)
            sht2958.cells(rprw3, cl) = rng(rw, cl)
        Next
        rprw3 = rprw3 + 1
    End If
    If Right(rng(rw, 6), 4) = "2966" Then
        For cl = 1 To UBound(rng, 2)
            sht2966.cells(rprw4, cl) = rng(rw, cl)
        Next
        rprw4 = rprw4 + 1
    End If
    If Right(rng(rw, 6), 4) = "2990" Then
        For cl = 1 To UBound(rng, 2)
            sht2990.cells(rprw5, cl) = rng(rw, cl)
        Next
        rprw5 = rprw5 + 1
    End If
    If Right(rng(rw, 6), 4) = "9111" Then
        For cl = 1 To UBound(rng, 2)
            sht9111.cells(rprw6, cl) = rng(rw, cl)
        Next
        rprw6 = rprw6 + 1
    End If
    If Right(rng(rw, 6), 4) = "9129" Then
        For cl = 1 To UBound(rng, 2)
            sht9129.cells(rprw7, cl) = rng(rw, cl)
        Next
        rprw7 = rprw7 + 1
    End If
Next


End Sub

This code scans sheet "shtWF" for project numbers and if found copies the data to the correct project sheet. The code seems verbose and I know one of you geniuses will be able to show me the way.

Thanks in advance,

A guy trying to be better.
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
A couple of examples:

VBA Code: 
Rng = shtWF.Cells(1, 1).CurrentRegion

For rw = 1 To UBound(Rng)
    rRng = Right(Rng(rw, 6), 4)
    If rRng = "1500" Then
        sht1500.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    ElseIf rRng = "3480" Then
        sht3480.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    ElseIf rRng = "2958" Then
        sht2958.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    'ElseIf ...
        
    End If

Next rw

You'll notice the use of If, ElseIf,... , Endif; and also the lack of the second loop as the row is copied in one block

OR

VBA Code: 
Rng = shtWF.Cells(1, 1).CurrentRegion

On Error Resume Next
For rw = 1 To UBound(Rng)
    rRng = Right(Rng(rw, 6), 4)
    Sheets(rRng).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
Next rw
On Error GoTo 0
No If-ElseIf-...-End If; the sheet name is used instead of the code name (and of course this is possible only if the real sheet names are similar to the codenames)

AND (variant for both)
Rather than using ...Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value try using
VBA Code: 
...Resize(1, UBound(Rng)).Value = Application.WorksheetFunction.Index(Rng, rw, 0)

Bye
 
Upvote 0
Solution
Are you only interested in using arrays ? This can be done using advanced filter.

Here is just a sample it would be modified to accommodate your actual sheet names and would probably set up and delete the criteria range I1:I2 on the fly (is is hard coded at the moment)

VBA Code: 
Sub Dispatch_AdvancedFilter()

    Dim shtWF As Worksheet
    Dim outSht As Worksheet
    Dim arrOutSht As Variant
    Dim shtName As Variant
    Dim srcRng As Range
    Dim critRng As Range
    Dim outRng As Range
    Dim outLastRow As Long
        
    Set shtWF = Worksheets("Data")
    Set srcRng = shtWF.Cells(1, 1).CurrentRegion
    
    arrOutSht = Array("1500", "3480")
    Set critRng = shtWF.Range("I1:I2")
    
    For Each shtName In arrOutSht
        Set outSht = Worksheets(shtName)
        outLastRow = outSht.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Set outRng = outSht.Cells(outLastRow, "A")
        critRng.Cells(2, 1).Formula = "=RIGHT(F2,4)=" & """" & shtName & """"
    
        srcRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=critRng, _
                        CopyToRange:=outRng, Unique:=False
        outRng.EntireRow.Delete
    
    Next shtName

End Sub
 
Upvote 0
Anthony47 said:
A couple of examples:

VBA Code: 
Rng = shtWF.Cells(1, 1).CurrentRegion

For rw = 1 To UBound(Rng)
    rRng = Right(Rng(rw, 6), 4)
    If rRng = "1500" Then
        sht1500.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    ElseIf rRng = "3480" Then
        sht3480.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    ElseIf rRng = "2958" Then
        sht2958.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    'ElseIf ...
       
    End If

Next rw

You'll notice the use of If, ElseIf,... , Endif; and also the lack of the second loop as the row is copied in one block

OR

VBA Code: 
Rng = shtWF.Cells(1, 1).CurrentRegion

On Error Resume Next
For rw = 1 To UBound(Rng)
    rRng = Right(Rng(rw, 6), 4)
    Sheets(rRng).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
Next rw
On Error GoTo 0
No If-ElseIf-...-End If; the sheet name is used instead of the code name (and of course this is possible only if the real sheet names are similar to the codenames)

AND (variant for both)
Rather than using ...Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value try using
VBA Code: 
...Resize(1, UBound(Rng)).Value = Application.WorksheetFunction.Index(Rng, rw, 0)

Bye
Click to expand...
Anthony, thank you for sharing! Holy crap your second code is fast!! However, what if I want my sheet names to end in the four digits as opposed to only being labeled as the numbers? For example, instead of a sheet being named "1500" it would be named "Stapleton (1500)". I was thinking there has to be a way to a use mid statement to achieve this but I can't seem to wrap my head around it.
 
Upvote 0
Alex Blakenburg said:
Are you only interested in using arrays ? This can be done using advanced filter.

Here is just a sample it would be modified to accommodate your actual sheet names and would probably set up and delete the criteria range I1:I2 on the fly (is is hard coded at the moment)

VBA Code: 
Sub Dispatch_AdvancedFilter()

    Dim shtWF As Worksheet
    Dim outSht As Worksheet
    Dim arrOutSht As Variant
    Dim shtName As Variant
    Dim srcRng As Range
    Dim critRng As Range
    Dim outRng As Range
    Dim outLastRow As Long
       
    Set shtWF = Worksheets("Data")
    Set srcRng = shtWF.Cells(1, 1).CurrentRegion
   
    arrOutSht = Array("1500", "3480")
    Set critRng = shtWF.Range("I1:I2")
   
    For Each shtName In arrOutSht
        Set outSht = Worksheets(shtName)
        outLastRow = outSht.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Set outRng = outSht.Cells(outLastRow, "A")
        critRng.Cells(2, 1).Formula = "=RIGHT(F2,4)=" & """" & shtName & """"
   
        srcRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=critRng, _
                        CopyToRange:=outRng, Unique:=False
        outRng.EntireRow.Delete
   
    Next shtName

End Sub
Click to expand...
I wanted to use an array just for the speed of processing many records. However, this is a great idea that I have never thought of! Thank you for sharing, Alex. I think a variation of this may be the answer for a project I have on the backburner. May I message you directly if I have questions putting it to use in the near future?
 
Upvote 0
thank you for sharing! Holy crap your second code is fast!! However, what if I want my sheet names to end in the four digits as opposed to only being labeled as the numbers? For example, instead of a sheet being named "1500" it would be named "Stapleton (1500)"
Click to expand...
The first code (the one that uses CodeNames) is fast quite as the second one; the second one seems faster only because it's more concise ;)

If your sheet names only "include" the number then things became a little bit more complicated (in terms of code), because we have to create a catalogue of the sheets and then scan this catalogue for detecting the sheet to be used, and either it'll become slower than using the CodeNames or overcomplicated to try staying superfast.

Since there is not any advantage in making the code slower than the first proposal, let's go with the overcomplication; for example this code:
Code: 
'Initial dims:
Dim myDic As Object, myK As String, shN As String, rRng As String
'
Rng = shtWF.Cells(1, 1).CurrentRegion
'
'Create a Dictionary of the suffixes:
Set myDic = CreateObject("Scripting.Dictionary")
For I = 1 To Worksheets.Count
    shN = Worksheets(I).Name & "("
    myK = Replace(Split(shN, "(", , vbTextCompare)(1), ")", "")
    If myDic.Exists(myK) Then
        MsgBox ("Two sheets with the same numeric suffix? Process aborted")
        Exit Sub
    Else
        myDic.Add (myK), I
    End If
Next I
'Cycle through the data and paste to the correct sheet:
On Error Resume Next
For rw = 1 To UBound(Rng)
    rRng = Right(Rng(rw, 6), 4)
    If myDic.Exists(rRng) Then
        Sheets(myDic.Item(rRng)).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    End If
Next rw
On Error GoTo 0
As you see we create at the beginning a "dictionary" of the suffixes contained in the sheet names (that assume the syntax is AnythingAsYouLike(xyzv), and the opening parenthesys is the delimiter of the 4 key characters) then we cycle through the data and use that dictionary to point the destination sheet.

Give it a try… but even in case it works my recommandation goes for using the CodeNames with the If /ElseIf /ElseIf /... / End If structure
 
Upvote 0
Darranimo said:
I wanted to use an array just for the speed of processing many records. However, this is a great idea that I have never thought of! Thank you for sharing, Alex. I think a variation of this may be the answer for a project I have on the backburner. May I message you directly if I have questions putting it to use in the near future?
Click to expand...
The forum is aimed at sharing knowledge both between those asking questions and those answering and this is best done by creating a thread.
I am happy to help so if you create a new thread relating to the Advanced Filtering, just @mention me and I will get a notification.
 
Upvote 0
Anthony47 said:
A couple of examples:

VBA Code: 
Rng = shtWF.Cells(1, 1).CurrentRegion

For rw = 1 To UBound(Rng)
    rRng = Right(Rng(rw, 6), 4)
    If rRng = "1500" Then
        sht1500.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    ElseIf rRng = "3480" Then
        sht3480.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    ElseIf rRng = "2958" Then
        sht2958.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
    'ElseIf ...
       
    End If

Next rw

You'll notice the use of If, ElseIf,... , Endif; and also the lack of the second loop as the row is copied in one block

OR

VBA Code: 
Rng = shtWF.Cells(1, 1).CurrentRegion

On Error Resume Next
For rw = 1 To UBound(Rng)
    rRng = Right(Rng(rw, 6), 4)
    Sheets(rRng).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value
Next rw
On Error GoTo 0
No If-ElseIf-...-End If; the sheet name is used instead of the code name (and of course this is possible only if the real sheet names are similar to the codenames)

AND (variant for both)
Rather than using ...Resize(1, UBound(Rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(Rng)).Value try using
VBA Code: 
...Resize(1, UBound(Rng)).Value = Application.WorksheetFunction.Index(Rng, rw, 0)

Bye
Click to expand...
Anthony, I ran into a weird issue but other than that your code has been working perfectly. I am hoping you can help me once again. As a reminder here is the code you helped me complete:
VBA Code: 
Private Sub cmdDispatch_Click()
    Dim i As Integer
    Dim tbl As ListObject
    Dim lrw As Long
    Dim ws As Worksheets
    Dim sum As Range
    
    rng = shtWF.Cells(1, 1).CurrentRegion
    
    On Error Resume Next
    For rw = 1 To UBound(rng)
        rRng = Right(rng(rw, 6), 4)
        Sheets(rRng).Cells(Sheets(rRng).Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(rng)).Value
    Next rw
    
    For i = 1 To Worksheets.Count - 1
        Set sum = Sheets(i).Range("X1")
        With Worksheets(i)
            For Each tbl In .ListObjects
                lrw = .Cells(.Rows.Count, "A").End(xlUp).Row
                tbl.Resize .Range("A3", "t" & lrw)
            Next
        sum.Formula = sum.Formula
        End With
    Next i
    
    shtWF.Cells.clear
End Sub

It is taking data from shtWF and disbursing it to different sheets in the workbook based on project code. The data range on shtWF is always columns A:S. I recently ran the code with fewer lines of data on shtWF (13 to be exact) and while data exists on columns A:S it only distributed columns A:N. It only seems to happen when the data set is small though. Do you have any ideas on what may be causing the code to ignore/not distribute columns O:S?
 
Upvote 0
Darranimo said:
Anthony, I ran into a weird issue but other than that your code has been working perfectly. I am hoping you can help me once again. As a reminder here is the code you helped me complete:
VBA Code: 
Private Sub cmdDispatch_Click()
    Dim i As Integer
    Dim tbl As ListObject
    Dim lrw As Long
    Dim ws As Worksheets
    Dim sum As Range
   
    rng = shtWF.Cells(1, 1).CurrentRegion
   
    On Error Resume Next
    For rw = 1 To UBound(rng)
        rRng = Right(rng(rw, 6), 4)
        Sheets(rRng).Cells(Sheets(rRng).Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(rng)).Value = shtWF.Cells(rw, 1).Resize(1, UBound(rng)).Value
    Next rw
   
    For i = 1 To Worksheets.Count - 1
        Set sum = Sheets(i).Range("X1")
        With Worksheets(i)
            For Each tbl In .ListObjects
                lrw = .Cells(.Rows.Count, "A").End(xlUp).Row
                tbl.Resize .Range("A3", "t" & lrw)
            Next
        sum.Formula = sum.Formula
        End With
    Next i
   
    shtWF.Cells.clear
End Sub

It is taking data from shtWF and disbursing it to different sheets in the workbook based on project code. The data range on shtWF is always columns A:S. I recently ran the code with fewer lines of data on shtWF (13 to be exact) and while data exists on columns A:S it only distributed columns A:N. It only seems to happen when the data set is small though. Do you have any ideas on what may be causing the code to ignore/not distribute columns O:S?
Click to expand...
Okay. I just discovered something... this code will only distribute the number of columns as there are rows on shtWF. So if there are 5 rows of data on shtWF it will only distribute columns A:E. I hope you can help!
 
Upvote 0
Darranimo said:
Okay. I just discovered something... this code will only distribute the number of columns as there are rows on shtWF. So if there are 5 rows of data on shtWF it will only distribute columns A:E. I hope you can help!
Click to expand...
I FIXED IT!!!!!!!!!!!! Never mind. And thanks again!
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
Copy value of Cell to the right - thought I had it
2
Replies
10
Views
671
netrixuser
N
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
611
kevin9999
K
B
  • Question
Excel 365 Compare Date & Copy Cell Data for Data Base
2 3 4
Replies
33
Views
758
skillilea
S
P
  • Locked
  • Question
Conditional Format gradient low number to high number
Replies
1
Views
389
Fluff
Fluff
N
  • Question
use same VBA code in a different column
Replies
4
Views
355
Joe4
Joe4

Forum statistics

Threads
1,214,806
Messages
6,121,672
Members
449,045
Latest member
Marcus05

Share this page

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