Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

Troubleshooting
Research
Professional Opinions
Ask a Question
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE

troubleshooting Question

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

Avatar of bsharath
bsharathFlag for India asked on
Microsoft OfficeMicrosoft ExcelMicrosoft Applications
8 Comments1 Solution360 ViewsLast Modified:
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
ASKER CERTIFIED SOLUTION
Avatar of jeverist
jeveristFlag of United States of America image

Our community of experts have been thoroughly vetted for their expertise and industry experience.

Commented:
This problem has been solved!
Unlock 1 Answer and 8 Comments.
See Answers