How do I simplify this macro?

**snooze24** · 10-20-2009, 04:34 PM

So I'm doing the same thing over and over for each worksheet that I have and its actually not working anymore, However when I just one run one set it works perfectly fine. The macro is supposed to copy any line that has the status Sold to another worksheet. Thanks in advance

Sub DidCellsChange()
   
    Dim cell        As Range
    
    For Each cell In Worksheets("ShirinJewelers").Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets("ShirinSold").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
    Next cell
    
        For Each cell In Worksheets("Treasures").Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets("TreaChiSold").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
    Next cell
    
        For Each cell In Worksheets("ExoticDiamonds").Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets("ExoticSold").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
    Next cell
    
            For Each cell In Worksheets("Highline").Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets("HighSold").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
    Next cell
    
        For Each cell In Worksheets("TreasuresJefferson").Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets("TreaJeffSold").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
    Next cell
    
        For Each cell In Worksheets("Ajs").Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets("AjsSold").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
    Next cell
    
        For Each cell In Worksheets("GoldenFever").Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets("GoldFevSold").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
    Next cell
    
        For Each cell In Worksheets("ForeverDiamonds").Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets("ForevDiaSold").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
    Next cell
    
        For Each cell In Worksheets("DiamondTreasures").Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets("DiaTreaSold").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
        
        
    Next cell
End Sub

**davegugg** · 10-20-2009, 04:47 PM

I don't know of a way to make it more efficient, but you can get rid of all the redundant typing by using a variable for the worksheet name, then calling the sub once for each different worksheet.

Example:

Sub DidCellsChange(WorksheetName As String)
   
    Dim cell        As Range
    
    For Each cell In Worksheets(WorksheetName).Range("E4:E50")
        If cell.Value = "Sold" Then
            With Cells(cell.Row, "A").Resize(, 17)
                Worksheets(WorksheetName).Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 6).Value = .Value
                .ClearContents
            End With
        End If
    Next cell
    
End Sub

Sub snooze24()

DidCellsChange "ShirinJewelers"
DidCellsChange "Treasures"
DidCellsChange "ExoticDiamonds"
DidCellsChange "Highline"
DidCellsChange "TreasuresJefferson"
DidCellsChange "Ajs"
DidCellsChange "GoldenFever"
DidCellsChange "ForeverDiamonds"
DidCellsChange "DiamondTreasures"

End Sub

If you need anything else please ask.