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 ExplicitSub Matchup() Dim ws1 As Worksheet, ws2 As Worksheet Dim i As Integer, j As Integer, cntX As Integer, cntY As Integer, cntZ As IntegerApplication.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:=xlDownApplication.DisplayAlerts = TrueEnd Sub
Open in new window