Sub Macro1()
'
' Macro1 Macro
'
'
Lr = Selection.SpecialCells(xlCellTypeLastCell).Row
Range("A2:G" & Lr).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & Lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("D2:D" & Lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C2:C" & Lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec", DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A2:G" & Lr)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("E2:E" & Lr).FormulaR1C1 = "=IF(OR(RC[-4]=R[-1]C[-4],RC[-4]=R[1]C[-4]),1,0)"
Range("F2:F" & Lr).FormulaR1C1 = _
"=IF(AND(R[-1]C[-5]=RC[-5],RC[-1]=1),(RC[-2]-R[-1]C[-2])*12+MONTH(1&RC[-3])-MONTH(1&R[-1]C[-3]),"""")"
Range("G2:G" & Lr).FormulaR1C1 = _
"=IF(AND(RC[-2]=1,RC[-1]>0,RC[-1]<7),1,0)"
Range("A2:G" & Lr).Value = Range("A2:G" & Lr).Value
Range("H2:H" & Lr).Value = ""
SR = 2
10 If SR > Lr Then GoTo 20
Range("G" & SR & ":G" & Lr).Select
Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
, SearchFormat:=False).Activate
SR = ActiveCell.Row + 1
strValueToPick = ActiveCell.Offset(0, -6).Value
Range("A2:A" & Lr).Select
Set rngLook = Selection
With rngLook
Set rngFind = .Find(strValueToPick, .Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFind Is Nothing Then
strFirstAddress = rngFind.Address
Set rngPicked = rngFind
Do
Set rngPicked = Union(rngPicked, rngFind)
Set rngFind = .FindNext(rngFind)
Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
End If
End With
If Not rngPicked Is Nothing Then
rngPicked.Offset(0, 7).Value = 1
End If
GoTo 10
20 ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("H2:H" & Lr), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & Lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A2:H" & Lr)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("H2:H" & Lr).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Lr = ActiveCell.Row - 1
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Export").Delete
Application.DisplayAlerts = True
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "Export"
Range("A1:D" & Lr).Value = Sheets("Sheet1").Range("A1:D" & Lr).Value
Range("E1:E" & Lr).Value = Sheets("Sheet1").Range("F1:F" & Lr).Value
Range("E1").Value = "Months"
End Sub
Bookmarks