M
MacroLearning
Scenario...
Sort by month, extract current month, copy to new sheet and then pivot. So
far, I've only been able to succeed in sorting only. The INput box will come
up, and the new sheet is added, but not the rest. Could someone look this
over and tell me what I'm doing wrong? I haven't gotten to the pivoting this
yet...
Sub MakePivots()
Dim sFile
Dim xlBook As Excel.Workbook
Dim xlSheet1 As Worksheet
'OPEN CURRENT MONTH HIRE REPORT
MsgBox "Open this month's HIRE report", [vbOKOnly]
sFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If sFile <> False Then
End If
Set xlBook = Workbooks.Open(sFile)
Set xlSheet1 = xlBook.Worksheets("YTD")
'SELECT THE ENTIRE REPORT
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
'SORT THE SELECTION
Selection.Sort Key1:=Range("BI2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long
Application.ScreenUpdating = False
Dim Month As String, Title As String
Dim ChangeMonth As Variant
Month = ""
Title = "Update Month"
ChangeMonth = Application.InputBox(Month, Title)
Dim UserRange As Range
MyArr = Array(Month)
Rcount = 0
With Sheets("YTD").Range("BI:BI")
For I = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
' This example will only copy the value
Sheets.Add
ActiveSheet.Range("A" & Rcount).Value = Rng.Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
Application.ScreenUpdating = True
Sort by month, extract current month, copy to new sheet and then pivot. So
far, I've only been able to succeed in sorting only. The INput box will come
up, and the new sheet is added, but not the rest. Could someone look this
over and tell me what I'm doing wrong? I haven't gotten to the pivoting this
yet...
Sub MakePivots()
Dim sFile
Dim xlBook As Excel.Workbook
Dim xlSheet1 As Worksheet
'OPEN CURRENT MONTH HIRE REPORT
MsgBox "Open this month's HIRE report", [vbOKOnly]
sFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If sFile <> False Then
End If
Set xlBook = Workbooks.Open(sFile)
Set xlSheet1 = xlBook.Worksheets("YTD")
'SELECT THE ENTIRE REPORT
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
'SORT THE SELECTION
Selection.Sort Key1:=Range("BI2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long
Application.ScreenUpdating = False
Dim Month As String, Title As String
Dim ChangeMonth As Variant
Month = ""
Title = "Update Month"
ChangeMonth = Application.InputBox(Month, Title)
Dim UserRange As Range
MyArr = Array(Month)
Rcount = 0
With Sheets("YTD").Range("BI:BI")
For I = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
' This example will only copy the value
Sheets.Add
ActiveSheet.Range("A" & Rcount).Value = Rng.Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
Application.ScreenUpdating = True