Avatar of bsharath
bsharath
Flag for India asked on

Stats Code excel macro need one change for it not to clear the sheet each time run rather place the data in Row 400.

Hi,

Stats Code excel macro need one change for it not to clear the sheet each time run rather place the data in Row 400.
When ever i want to run i will manually delete the whole data in sheet and run all the macros 1 by one that i have.

Regards
Sharath
Option Explicit
Sub Matchup()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim i As Integer, j As Integer, cntX As Integer, cntY As Integer, cntZ As Integer
Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Stats").Delete
    Sheets.Add After:=Sheets(Worksheets.Count)
    ActiveSheet.Name = "Stats"
    ActiveSheet.Cells.Interior.ColorIndex = 2
    Set ws1 = Sheets("DCS")
    Set ws2 = Sheets("Stats")
    ws2.Cells.Delete
    ws1.Columns("BH:BH").Copy
    ws2.Range("G1").PasteSpecial
    Application.CutCopyMode = False
    ws2.Range("G1").Delete
    ws2.Columns("G:G").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws2.Columns( _
                                                                         "A:A"), Unique:=True

    ws2.Range("B1") = "Rental"
    ws2.Range("C1") = "Owned"
    ws2.Range("D1") = "Totals"

    ws2.Range("A1:D" & ws2.Cells(65536, "A").End(xlUp).Row + 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    ws2.Columns("G:G").Delete
    ws2.Rows("1:1").Font.Bold = True
    ws2.Cells.EntireColumn.AutoFit

    For i = 2 To ws2.Cells(65536, "A").End(xlUp).Row
        cntX = 0
        cntY = 0
        cntZ = 0
        For j = 2 To ws1.Cells(65536, "S").End(xlUp).Row
            If UCase(ws1.Range("BH" & j)) = UCase(ws2.Range("A" & i)) And UCase(ws1.Range("S" & j)) = "RENTAL" Then
                cntX = cntX + 1
            End If
            If UCase(ws1.Range("BH" & j)) = UCase(ws2.Range("A" & i)) And UCase(ws1.Range("S" & j)) = "OWNED" Then
                cntY = cntY + 1
            End If
        Next
        cntZ = cntX + cntY
        ws2.Range("B" & i) = cntX
        ws2.Range("C" & i) = cntY
        ws2.Range("D" & i) = cntZ
    Next
    ws2.Range("B" & ws2.Cells(65536, "A").End(xlUp).Row + 1) = Application.WorksheetFunction.Sum(Range("B2:B" & ws2.Cells(65536, "A").End(xlUp).Row))
    ws2.Range("C" & ws2.Cells(65536, "A").End(xlUp).Row + 1) = Application.WorksheetFunction.Sum(Range("C2:C" & ws2.Cells(65536, "A").End(xlUp).Row))
    ws2.Range("D" & ws2.Cells(65536, "A").End(xlUp).Row + 1) = Application.WorksheetFunction.Sum(Range("D2:D" & ws2.Cells(65536, "A").End(xlUp).Row))
    'Rows("1:314").Insert Shift:=xlDown
Application.DisplayAlerts = True
End Sub

Open in new window

Microsoft ExcelMicrosoft ApplicationsMicrosoft Office

Avatar of undefined
Last Comment
bsharath

8/22/2022 - Mon
nutsch

Try this update.

Sub Matchup()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim i As Integer, j As Integer, cntX As Integer, cntY As Integer, cntZ As Integer
Application.DisplayAlerts = False
    On Error Resume Next
    ActiveSheet.Cells.Interior.ColorIndex = 2
    Set ws1 = Sheets("DCS")
    Set ws2 = Sheets("Stats")
    ws1.Columns("BH:BH").Resize(Rows.Count - 400).Copy
    ws2.Range("G400").PasteSpecial
    Application.CutCopyMode = False
    ws2.Range("G400").Delete
    ws2.Columns("G:G").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws2.Columns( _
                                                                         "A:A"), Unique:=True

    ws2.Range("B400") = "Rental"
    ws2.Range("C400") = "Owned"
    ws2.Range("D400") = "Totals"

    ws2.Range("A1:D" & ws2.Cells(65536, "A").End(xlUp).Row + 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    ws2.Columns("G:G").Delete
    ws2.Rows(400).Font.Bold = True
    ws2.Cells.EntireColumn.AutoFit

    For i = 401 To ws2.Cells(65536, "A").End(xlUp).Row
        cntX = 0
        cntY = 0
        cntZ = 0
        For j = 401 To ws1.Cells(65536, "S").End(xlUp).Row
            If UCase(ws1.Range("BH" & j)) = UCase(ws2.Range("A" & i)) And UCase(ws1.Range("S" & j)) = "RENTAL" Then
                cntX = cntX + 1
            End If
            If UCase(ws1.Range("BH" & j)) = UCase(ws2.Range("A" & i)) And UCase(ws1.Range("S" & j)) = "OWNED" Then
                cntY = cntY + 1
            End If
        Next
        cntZ = cntX + cntY
        ws2.Range("B" & i) = cntX
        ws2.Range("C" & i) = cntY
        ws2.Range("D" & i) = cntZ
    Next
    ws2.Range("B" & ws2.Cells(65536, "A").End(xlUp).Row + 1) = Application.WorksheetFunction.Sum(Range("B401:B" & ws2.Cells(65536, "A").End(xlUp).Row))
    ws2.Range("C" & ws2.Cells(65536, "A").End(xlUp).Row + 1) = Application.WorksheetFunction.Sum(Range("C401:C" & ws2.Cells(65536, "A").End(xlUp).Row))
    ws2.Range("D" & ws2.Cells(65536, "A").End(xlUp).Row + 1) = Application.WorksheetFunction.Sum(Range("D401:D" & ws2.Cells(65536, "A").End(xlUp).Row))
    'Rows("1:314").Insert Shift:=xlDown
Application.DisplayAlerts = True
End Sub

Open in new window

bsharath

ASKER
Thanks but i dont get the results.
One row data in row 2 and the headers in row 400 nothing else gets populated...
nutsch

do you have a template file you can load?
I started with Experts Exchange in 2004 and it's been a mainstay of my professional computing life since. It helped me launch a career as a programmer / Oracle data analyst
William Peck
bsharath

ASKER
Attached the sample file
Projectmanager.xls
jeverist

Hi bsharath,

Here another option for you.  See your revised workbook attached.

Jim
Sub Matchup()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, cntX As Long, cntY As Long, cntZ As Long
    
Application.DisplayAlerts = False
    
Set ws1 = Sheets("DCS")
    
Set ws2 = Nothing
On Error Resume Next
Set ws2 = Sheets("Stats")
On Error GoTo 0
    
If ws2 Is Nothing Then
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    Set ws2 = ActiveSheet
    ws2.Name = "Stats"
    ws2.Cells.Interior.ColorIndex = 2
End If
    
Intersect(ws1.Columns("BH"), ws1.UsedRange).Copy
ws2.Range("G400").PasteSpecial
Application.CutCopyMode = False
    
ws2.Range("G400").Delete
Range(ws2.Range("G400"), ws2.Cells(ws2.Rows.Count, "G").End(xlUp)).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=ws2.Range("A400"), Unique:=True
    
ws2.Range("B400") = "Rental"
ws2.Range("C400") = "Owned"
ws2.Range("D400") = "Totals"
    
ws2.Range(ws2.Range("A400"), ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1)).Resize(, 4).Borders.LineStyle = xlContinuous
    
ws2.Columns("G").Delete
ws2.Rows("400").Font.Bold = True
ws2.Cells.EntireColumn.AutoFit
    
For i = 401 To ws2.Cells(65536, "A").End(xlUp).Row
    cntX = 0
    cntY = 0
    cntZ = 0
    For j = 2 To ws1.Cells(65536, "S").End(xlUp).Row
        If UCase(ws1.Range("BH" & j)) = UCase(ws2.Range("A" & i)) And UCase(ws1.Range("S" & j)) = "RENTAL" Then
            cntX = cntX + 1
        End If
        If UCase(ws1.Range("BH" & j)) = UCase(ws2.Range("A" & i)) And UCase(ws1.Range("S" & j)) = "OWNED" Then
            cntY = cntY + 1
        End If
    Next
    cntZ = cntX + cntY
    ws2.Range("B" & i) = cntX
    ws2.Range("C" & i) = cntY
    ws2.Range("D" & i) = cntZ
Next
    
ws2.Range("B" & ws2.Cells(65536, "A").End(xlUp).Row + 1) = Application.WorksheetFunction.Sum(Range("B400:B" & ws2.Cells(65536, "A").End(xlUp).Row))
ws2.Range("C" & ws2.Cells(65536, "A").End(xlUp).Row + 1) = Application.WorksheetFunction.Sum(Range("C400:C" & ws2.Cells(65536, "A").End(xlUp).Row))
ws2.Range("D" & ws2.Cells(65536, "A").End(xlUp).Row + 1) = Application.WorksheetFunction.Sum(Range("D400:D" & ws2.Cells(65536, "A").End(xlUp).Row))
    
Application.CutCopyMode = False
Application.Goto ws2.[A400]
Application.ScreenUpdating = True
    
End Sub

Open in new window

Q-25158649---Summarize-Data.xls
bsharath

ASKER
thanks works perfect
If i need to change it to 293 row what should i do... I tried changing all 400 to 293 but no count gets populated
⚡ FREE TRIAL OFFER
Try out a week of full access for free.
Find out why thousands trust the EE community with their toughest problems.
ASKER CERTIFIED SOLUTION
jeverist

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
GET A PERSONALIZED SOLUTION
Ask your own question & get feedback from real experts
Find out why thousands trust the EE community with their toughest problems.
bsharath

ASKER