Copying row into different worksheet based on string in cell

A

amanda_hemi

New member
Joined
Nov 8, 2018
Messages
3
Reaction score
0
Points
0
Excel Version(s)
Excel 16 i believe
Hello,

I have experience in R but none with VBA. I have been looking for a way to copy a row of data into a different worksheet based on a string of characters within the cell.

I have looked and have found parts to my problem but can't seem to combine them all together to work.
forum.PNG
The above is an example of how my data is set up. I want to sort the styles that start with an A or S to be sorted into a worksheet "Sport", the styles that dont start with A, or S, that contain 01-, 02-,... 09- to be copied onto a worksheey called "Bags", and stlyle that contains 10- to be copied to a worksheet called wallets.

I was looking into doing a for loop with if then statements, but I can't get it all to work together.
 
Code: 
Option Explicit


Sub Amanda()
    Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, s4 As Worksheet
    Set s1 = Sheets("Main")    'change this to whatever your primary sheet is named
    Set s2 = Sheets("Sport")
    Set s3 = Sheets("Bags")
    Set s4 = Sheets("Wallets")
    Dim i As Long, lr As Long, lr2 As Long, lr3 As Long, lr4 As Long
    Application.ScreenUpdating = False
    lr = s1.Range("B" & Rows.Count).End(xlUp).Row
    For i = 2 To lr
        lr2 = s2.Range("B" & Rows.Count).End(xlUp).Row + 1
        lr3 = s3.Range("B" & Rows.Count).End(xlUp).Row + 1
        lr4 = s4.Range("B" & Rows.Count).End(xlUp).Row + 1
        If InStr(s1.Range("B" & i), "A") = 1 Or InStr(s1.Range("B" & i), "S") = 1 Then
            s1.Range("A" & i & ":C" & i).Copy s2.Range("A" & lr2)
        ElseIf s1.Range("B" & i) Like "0" & Chr(42) & "-" & Chr(42) Then
            s1.Range("A" & i & ":C" & i).Copy s3.Range("A" & lr3)
        ElseIf InStr(s1.Range("B" & i), "10-") > 0 Then
            s1.Range("A" & i & ":C" & i).Copy s4.Range("A" & lr4)
        End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "complete"
End Sub
 
Hello,

Thank you so much! I edited to work more specifically to what I need but I am getting an error code "Subscript out of Range".

I am not sure how to fix this, because I cant identify what is wrong.

Option Explicit




Sub OTS()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, s4 As Worksheet, s5 As Worksheet, s6 As Worksheet, s7 As Worksheet, s8 As Worksheet

Set s1 = Sheets("OTS") 'change this to whatever your primary sheet is named
Set s2 = Sheets("HANDBAG")
Set s3 = Sheets("SPORT")
Set s4 = Sheets("COSMETIC")
Set s5 = Sheets("FANNY")
Set s6 = Sheets("Wallet")
Set s7 = Sheets("DIAPER BAG")
Set s8 = Sheets("PHONE CASE")

Dim i As Long, lr As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long, lr7 As Long, lr8 As Long
Application.ScreenUpdating = False
lr = s1.Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lr
lr2 = s2.Range("B" & Rows.Count).End(xlUp).Row + 1
lr3 = s3.Range("B" & Rows.Count).End(xlUp).Row + 1
lr4 = s4.Range("B" & Rows.Count).End(xlUp).Row + 1
lr5 = s5.Range("B" & Rows.Count).End(xlUp).Row + 1
lr6 = s6.Range("B" & Rows.Count).End(xlUp).Row + 1
lr7 = s7.Range("B" & Rows.Count).End(xlUp).Row + 1
lr8 = s8.Range("B" & Rows.Count).End(xlUp).Row + 1
If InStr(s1.Range("B" & i), "A") = 1 Or InStr(s1.Range("B" & i), "S") = 1 Then
s1.Range("A" & i & ":E" & i).Copy s3.Range("A" & lr2)
ElseIf s1.Range("B" & i) Like "0" & Chr(42) & "-" & Chr(42) Or InStr(s1.Range("B" & i), "12-") > 0 Or InStr(s1.Range("B" & i), "19-") > 0 Then
s1.Range("A" & i & ":E" & i).Copy s2.Range("A" & lr3)
ElseIf InStr(s1.Range("B" & i), "10-") > 0 Then
s1.Range("A" & i & ":E" & i).Copy s6.Range("A" & lr4)
ElseIf InStr(s1.Range("B" & i), "14-") > 0 Then
s1.Range("A" & i & ":E" & i).Copy s4.Range("A" & lr5)
ElseIf InStr(s1.Range("B" & i), "15-") > 0 Then
s1.Range("A" & i & ":E" & i).Copy s5.Range("A" & lr6)
ElseIf InStr(s1.Range("B" & i), "17-") > 0 Then
s1.Range("A" & i & ":E" & i).Copy s7.Range("A" & lr7)
ElseIf InStr(s1.Range("B" & i), "18-") > 0 Then
s1.Range("A" & i & ":E" & i).Copy s8.Range("A" & lr8)
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "complete"
End Sub
 
I figured it out! Thank you so much for your help!! Can I ask one last question? I want to sum my last column, but the number of rows I have will be changing, what sort of range can I use? Is there a stop method I can use when the sum reaches an empty cell? TIA
 
Code: 
Option Explicit


Sub SumItUp()
    Dim lr As Long, x As Double
    lr = Range("A" & Rows.Count).End(xlUp).Row    'Change the A to your column
    x = WorksheetFunction.Sum(Range("A1:A" & lr))
    MsgBox ("Total is " & x)
End Sub
 
@amanda
Hi,
When posting code, please wrap it with code tags ( Edit code - select code - click the #button.)
It keeps the macro's structure and makes it easy to copy and handle.
Thank you
 
You must log in or register to reply here.
Back
Top