Hi
The following, slightly modified code from my first posting will work
for you.
First, delete rows 1:7 from your worksheet, then run the first macro.
Use the dropdown arrow on column A, to select the Part number required,
and you will have the data set out in the way that you want. Note that a
0 will appear where there is a 0 in the source data, but the cell will
be blank if there is no data recorded.
Also, the routine only shows the dates where data exists in any year,
rather than showing a long list of empty dates with just a few entries
(as is the case for some of your parts).
If you need every date listed, post back and the macro can be modified.
Sub Setupdata()
Dim i As Long, j As Long, k As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
If Range("D1").Value <> "Month/Day" Then
Rows("1:1").Insert Shift:=xlDown
Range("A1") = "Part Number": Range("B1") = "Eff Date": Range("C1") =
"Qty Used":
Range("D1") = "Month/Day"
Range("A1
1").AutoFilter
End If
Range("D1").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-2],""mm/dd"")"
Range("D1").Select
Selection.AutoFill Destination:=Range("D1
" & lr),
Type:=xlFillDefault
Range("A1
" & lr).Select
Selection.Sort Key1:=Range("D1"), Order1:=xlAscending,
Key2:=Range("A1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1,
MatchCase:= _
False, Orientation:=xlTopToBottom
Range("A2").Select
ActiveWindow.FreezePanes = True
End Sub
'=========================================================================
'-------------------------------------------------------------------------------------------------------------------------------------
Sub copydata()
Dim userange As Range, visrow As Long, i As Long, k As Long
Dim lr As Long, y As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
Columns("F:I").EntireColumn.Delete
Application.ScreenUpdating = False
Set userange = Range(Cells(2, 1), Cells(lr, 4))
visrow = Range("A2
" & lr).SpecialCells(xlCellTypeVisible).Row
Cells(1, 6) = Cells(visrow, 1)
Cells(1, 7) = 2005: Cells(1, 8) = 2006: Cells(1, 9) = 2007
k = 2
For i = visrow To lr
If Rows(i).EntireRow.Hidden = False Then
Cells(k, 6) = Cells(i, 4).Value
y = Year(Cells(i, 2)) - 1998
Cells(k, y) = Format(Cells(i, 3).Value, "#,##0")
If Cells(i + 1, 1) = Cells(i, 1) And Cells(i + 1, 4) = Cells(i, 4) Then
y = Year(Cells(i, 2)) - 1998
Cells(k, y) = Format(Cells(i, 3).Value, "#,##0")
i = i + 1
End If
If Cells(i + 1, 1) = Cells(i, 1) And Cells(i + 1, 4) = Cells(i, 4) Then
y = Year(Cells(i, 2)) - 1998
Cells(k, y) = Format(Cells(i, 3).Value, "#,##0")
i = i + 1
End If
k = k + 1
End If
Next i
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Instructions for copying code were included in my original posting.
If you wanted to, you could copy the second macro to a Worksheet
instead, and have it triggered automatically when you make your
selection from the dropdown.
Instead of copying the sub CopyData to a regular module, copy the
following to the worksheet concerned.
Right click on the sheet tab and paste the code below into the white
pane.
Now, when you make a selection for the dropdown in column A, the macro
will get triggered and show your results for that part number.
Private Sub Worksheet_Calculate()
If WorksheetFunction.CountA(Columns("A:A")) = _
WorksheetFunction.Subtotal(3, Columns("A:A")) Then Exit Sub
Application.EnableEvents = False
Dim userange As Range, visrow As Long, i As Long, k As Long
Dim lr As Long, y As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
Columns("F:I").EntireColumn.Delete
Application.ScreenUpdating = False
Set userange = Range(Cells(2, 1), Cells(lr, 4))
visrow = Range("A2
" & lr).SpecialCells(xlCellTypeVisible).Row
Cells(1, 6) = Cells(visrow, 1)
Cells(1, 7) = 2005: Cells(1, 8) = 2006: Cells(1, 9) = 2007
k = 2
For i = visrow To lr
If Rows(i).EntireRow.Hidden = False Then
Cells(k, 6) = Cells(i, 4).Value
y = Year(Cells(i, 2)) - 1998
Cells(k, y) = Format(Cells(i, 3).Value, "#,##0")
If Cells(i + 1, 1) = Cells(i, 1) And Cells(i + 1, 4) = Cells(i, 4) Then
y = Year(Cells(i, 2)) - 1998
Cells(k, y) = Format(Cells(i, 3).Value, "#,##0")
i = i + 1
End If
If Cells(i + 1, 1) = Cells(i, 1) And Cells(i + 1, 4) = Cells(i, 4) Then
y = Year(Cells(i, 2)) - 1998
Cells(k, y) = Format(Cells(i, 3).Value, "#,##0")
i = i + 1
End If
k = k + 1
End If
Next i
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
If you have trouble in doing this for yourself, send me your email
address and I will mail a working copy to you.
To mail me direct
roger AT technologyNOSPAM4u.co.U.K.
do the obvious with AT and remove NOSPAM from the address
