bsharath
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
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
Thanks but i dont get the results.
One row data in row 2 and the headers in row 400 nothing else gets populated...
One row data in row 2 and the headers in row 400 nothing else gets populated...
do you have a template file you can load?
ASKER
Attached the sample file
Projectmanager.xls
Projectmanager.xls
Hi bsharath,
Here another option for you. See your revised workbook attached.
Jim
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
Q-25158649---Summarize-Data.xls
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
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thank you works perfect
Any help on this
https://www.experts-exchange.com/questions/25097726/Update-data-from-one-sheet-to-another-need-an-addition.html
Any help on this
https://www.experts-exchange.com/questions/25097726/Update-data-from-one-sheet-to-another-need-an-addition.html
Open in new window