View Single Post
 
Old 12-18-2017, 10:11 PM
NoSparks NoSparks is offline Windows 7 64bit Office 2010 64bit
Excel Hobbyist
 
Join Date: Nov 2013
Location: British Columbia, Canada
Posts: 842
NoSparks is a glorious beacon of lightNoSparks is a glorious beacon of lightNoSparks is a glorious beacon of lightNoSparks is a glorious beacon of lightNoSparks is a glorious beacon of light
Default

Make a copy of Sheet1, by default it will be Sheet1 (2)
give this a try on the copy

Code:
Sub ChrisOK_macro()
' https://www.msofficeforums.com/excel-programming/37657
' Dec 18, 2017

    Dim lr As Long
    Dim rng As Range, cl As Range
    Dim Cust As String, x As Integer
    
 Application.ScreenUpdating = False
 
 With Sheets("Sheet1 (2)")
    
    'establish a range of Cust# in column A
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    For Each cl In .Range("A2:A" & lr)
        If Not IsEmpty(cl.Offset(, 3)) Then
            If rng Is Nothing Then
                Set rng = cl
            Else
                Set rng = Union(rng, cl)
            End If
        End If
    Next cl
    
    'get the cust name and copy it
    For Each cl In rng
        x = 1
        Cust = cl.Offset(, 3)
        Do Until IsEmpty(cl.Offset(x, 1))
            cl.Offset(x) = Cust
            x = x + 1
        Loop
    Next cl
    
    'delete all rows where col C is blank
    Range("C1:C" & lr).SpecialCells(xlBlanks).EntireRow.Delete
    
    'combine H I J K
    lr = .Cells(Rows.Count, "A").End(xlUp).Row  'new last row
    For Each cl In Range("G2:G" & lr)
        If IsEmpty(cl) Then
            cl.FormulaR1C1 = "=SUM(RC[1]:RC[4])"
            cl.Value = cl.Value
        End If
    Next cl
    
    'clear cols H I J K
    .Range("H2:K" & lr).ClearContents
    
End With

Application.ScreenUpdating = True

End Sub
Reply With Quote