I have the following code in a macro to copy the contents of C2 and D2 cells of the active worksheet and copy it down to the last row of the table.
1 Range("C:D").Insert Shift:=xlToRight
2 Range("C2").FormulaR1C1 = "=RIGHT(RC[2],4)"
3 Range("D2").FormulaR1C1 = "=LEFT(RC[1],LEN(RC[1])-5)"
4 lastrow = Range("A" & Rows.Count).End(xlUp).Row
5 Range("C2").Copy Range("C2:C" & lastrow)
6 lastrow = Range("B" & Rows.Count).End(xlUp).Row
7 Range("D2").Copy Range("D2:D" & lastrow)
I've been using this code for nearly 3 years now for my daily work but i just suddenly came across a file in which the dynamic range is not selected correctly at line 4 and 6. The sheet has around 30k lines but the formula only copies to the first 284 lines in both column C and D.
I first thought i was referring to a wrong sheet so i tried "lastrow = Activesheet.Range("A" & Rows.Count).End(xlUp).Row"as well as lastrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Rowto the same result.
Anyone can help me figure this out? I'm a bit rusty since it's been a while since i looked at anything remotely related to code...
(Can provide the file if needed)
Sub SSFormula()
Application.ScreenUpdating = False
Dim strPath As String
Dim lastcol%, dest As Range, lastrow%, pt As PivotTable
Dim iCol As Long
Dim iColEnd As Long
Dim strFileName As String
Dim strFileNameTemp As String
Application.DisplayAlerts = False
strFileNameTemp = Environ("USERPROFILE") & "\Desktop\SHELFSTOCK\" & Format(Now(), "DD-MMM-YYYY - hh mmAMPM") & " SHELFSTOCK" & ".xlsx"
ActiveWorkbook.SaveAs Filename:=strFileNameTemp, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.Workbooks.Open (strFileNameTemp)
On Error Resume Next
For x = 1 To 200
If Not Range("a1").Offset(0, x).IsEmpty(ActiveCell.Value) Then Range("A:A").Offset(0, x).TextToColumns Destination:=Range("A1").Offset(0, x), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Next x
Range("C:D").Delete Shift:=xlToLeft
lastrow = Sheets("Group_PositionList").Range("a" & Rows.Count).End(xlUp).Row
lastcol = Sheets("Group_PositionList").Cells(lastrow, Columns.Count).End(xlToLeft).Column
Sheets.Add
Set dest = Sheets("sheet1").[A1]
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Group_PositionList!R1C1:R" & lastrow & "C" & _
lastcol, Version:=6).CreatePivotTable TableDestination:=dest, TableName:="PivotTable2", DefaultVersion:=6
Set pt = Sheets("sheet1").PivotTables("PivotTable2")
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Product_ID")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Name")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable2").RowAxisLayout xlTabularRow
ActiveSheet.PivotTables("PivotTable2").RepeatAllLabels xlRepeatLabels
With ActiveSheet.PivotTables("PivotTable2")
.ColumnGrand = False
.RowGrand = False
End With
Set pt = ActiveSheet.PivotTables(1)
With pt
For Each pf In .PivotFields
pf.Subtotals(1) = True
pf.Subtotals(1) = False
Next pf
End With
Set pt = ActiveSheet.PivotTables(1)
With pt
iCol = 1
iColEnd = .PivotFields.Count
For iCol = 1 To iColEnd
With .PivotFields(iCol)
If .Orientation = 0 Then
.Orientation = xlDataField
End If
End With
Next iCol
End With
With ActiveSheet.PivotTable
.ManualUpdate = True
For Each pf In .DataFields
With pf
.Function = xlSum
.NumberFormat = "#,##0"
End With
Next pf
.ManualUpdate = False
End With
With ActiveSheet.PivotTables("PivotTable2").DataPivotField
.Orientation = xlRowField
.Position = 3
End With
pt.TableRange1.Copy
Sheets.Add
Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells.Columns.AutoFit
Cells.Replace What:="sum of ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:=".pln", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
.Range("C:D").Insert Shift:=xlToRight
.Range("C2:C" & lRow).Formula = "=RIGHT(E2,4)"
.Range("D2:D" & lRow).Formula = "=LEFT(E2,LEN(E2)-5)"
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("E:E").Delete Shift:=xlToLeft
Range("C1").FormulaR1C1 = "OUTLET"
Range("D1").FormulaR1C1 = "DISPLAY CATEGORY"
Range("E1").FormulaR1C1 = "SHELF STOCK"
Cells.Columns.AutoFit
Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
On Error GoTo Next_Block:
Range("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next_Block:
Rows("1:1").AutoFilter
Cells.Columns.AutoFit
Sheets("Sheet2").Name = "Position_by_Fixture"
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Sheets("Group_PositionList").Delete
Application.DisplayAlerts = True
Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Application.DisplayAlerts = False
strFileName = Environ("USERPROFILE") & "\Desktop\SHELFSTOCK\" & Range("'Position_by_Fixture'!D2").Text & " SHELFSTOCK" & ".xlsx"
ActiveWorkbook.SaveAs Filename:=strFileName, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Kill (strFileNameTemp)
Application.ScreenUpdating = True
End Sub
As suggested in the comments above, try this code (UNTESTED)
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("C:D").Insert Shift:=xlToRight
.Range("C2:C" & lRow).Formula = "=RIGHT(E2,4)"
.Range("D2:D" & lRow).Formula = "=LEFT(E2,LEN(E2)-5)"
End With
End Sub
Related
I have created a simple macro that will import 3 xls files into macro and will compare the data and will create a output file with limited fields. But I see my macro file is 33,446 KB even though the macro book sheets are empty.
is there any way to find out which line of code is taking time without doing step by step execution?
Input files & their file sizes
Excel macro file size
Sub Macro_Step_1()
Dim Wkb_1 As Workbook
Dim Autosht As Worksheet, DLDataSht As Worksheet, SAPdataSht As Worksheet, Osht As Worksheet
Set Wkb_1 = ThisWorkbook
Set Autosht = Wkb_1.Sheets("Automation")
Set DLDataSht = Wkb_1.Sheets("GLData")
Set SAPdataSht = Wkb_1.Sheets("YFIINTDSRP")
Set Osht = Wkb_1.Sheets("Output File")
Set Tempsht = Wkb_1.Sheets("Temp")
St = Now()
Call TurnOffStuff
wkbpath = Wkb_1.Path
'***************************************************************************************************************************************
FN = Dir(wkbpath & "\*.*")
Do While FN <> ""
Debug.Print FN
If LCase(FN) Like LCase("*Report*.xls") Then
Compinfo = Compinfo & "|" & FN
Compinfo = IIf(Left(Compinfo, 1) = "|", Mid(Compinfo, 2, Len(Compinfo)), Compinfo)
ElseIf LCase(FN) Like LCase("*Raw*.xlsx") Then
LMPTinfo = FN
End If
FN = Dir()
Loop
'*******************************************Input Files missing alert******************************************************************
If Compinfo = "" Or LMPTinfo = "" Then
ReportName = ""
ReportName = wkbpath & "\" & "Missing Input Files.txt"
Open ReportName For Output As #1
Close #1
Exit Sub
ReportName = ""
End If
'------------------------------------------------------------------------------
'//Clear Contents for Below mentioned Sheets Exluding Header
Wkb_1.Activate
DLDataSht.Rows("2:1000000").EntireRow.Clear
SAPdataSht.Rows("2:1000000").EntireRow.Clear
Tempsht.Rows("2:1000000").EntireRow.Clear
Osht.Rows("1:1000000").EntireRow.Clear
'*****************************Client Data***********************************************************************************************
RptName = Split(Compinfo, "|")
For Each Rsht In RptName
Call Copy_Compinfo_Data("" & Rsht & "", "", "YFIINTDSRP")
Next
Call Copy_LMPTinfo_Data("" & LMPTinfo & "", "", "GLData")
Call OutputMdl
Tempsht.Rows("1:1000000").EntireRow.Clear
'*********************************************************************************************************************************
Call TurnONStuff
'//Automation Run Time & Task Completetion Alert
MsgBox "Process Completed Within " & Format(Now() - St, "HH:MM:SS"), vbInformation
End Sub
Sub Copy_Compinfo_Data(IPWkb As String, IPSheet As String, DestSheetname As String)
Dim Del_1 As Long
Set Wkb_1 = ThisWorkbook
Set Tempsht = Wkb_1.Sheets("Temp")
Tempsht.Rows("1:1000000").EntireRow.Clear
wkbpath = ThisWorkbook.Path
ShtInx = IIf(IPSheet = "", 1, IPSheet)
Set ws_master = Workbooks.Open(wkbpath & "\" & IPWkb)
Shtname = ws_master.Sheets(1).Name
Set ws_Data = ws_master.Sheets(ShtInx)
Wkb_1.Activate
Set OrgFl = Wkb_1.Sheets(DestSheetname)
OrgFl.Select
ws_master.Sheets(1).Activate
Application.CutCopyMode = False
ws_Data.Cells.Copy
Tempsht.Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ws_master.Activate
Windows(IPWkb).Close savechanges:=False
Wkb_1.Activate: Tempsht.Select
'HDRrow = 1
Tempsht.Rows("1:7").EntireRow.Delete
Tempsht.Range("A:A").EntireColumn.Delete
Tempsht.Rows("2:2").EntireRow.Delete
Tempsht.Range("C:C").EntireColumn.Delete
Tempsht.Sort.SortFields.Clear
Tempsht.Sort.SortFields.Add2 Key:=Range("A2:A" & LR), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Tempsht.Sort
.SetRange Range("A1:AB" & LR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Wkb_1.Activate: Tempsht.Select
If Tempsht.AutoFilterMode Then Tempsht.AutoFilterMode = False
Tempsht.Range(Cells(1, 1), Cells(LR, LC)).AutoFilter field:=1, Criteria1:="Company Code"
If LR > 1 Then
Tempsht.Range(Cells(2, 1), Cells(LR, LC)).SpecialCells(xlCellTypeVisible).Delete
End If
Tempsht.ShowAllData
' For Del_1 = LR To 1 Step -1
'Wkb_1.Activate: Tempsht.Select
'Tempsht.Range(Cells(Del_1, 1), Cells(Del_1, LC)).Select
' Coun_ta = Application.WorksheetFunction.CountA(Tempsht.Range(Cells(Del_1, 1), Cells(Del_1, LR)))
' If Tempsht.Range("B" & Del_1) = "" And Coun_ta <= 0 Then
'Tempsht.Rows(Del_1).EntireRow.Select
'Tempsht.Rows(Del_1).EntireRow.Delete
' ElseIf Tempsht.Range("A" & Del_1) = "*" Then
'Tempsht.Rows(Del_1).EntireRow.Select
'Tempsht.Rows(Del_1).EntireRow.Delete
' End If
'Next
Wkb_1.Activate: Tempsht.Select
Tempsht.Cells(1, LC + 1) = "Report Name"
'Tempsht.Range(Cells(2, LC), Cells(LR, LC)).Select
Tempsht.Range(Cells(2, LC), Cells(LR, LC)) = IPWkb
Application.CutCopyMode = False
Tempsht.Range(Cells(2, 1), Cells(LR, LC)).Copy
Wkb_1.Activate
OrgFl.Select
OrgFl.Range("A" & LR + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Wkb_1.Activate: OrgFl.Select: OrgFl.Range("A1").Select
Application.CutCopyMode = False
End Sub
Sub Copy_LMPTinfo_Data(IPWkb As String, IPSheet As String, DestSheetname As String)
Set Wkb_1 = ThisWorkbook
Set Tempsht = Wkb_1.Sheets("Temp")
Set Osht = Wkb_1.Sheets("Output File")
Set DLDataSht = Wkb_1.Sheets("GLData")
Tempsht.Rows("1:1000000").EntireRow.Clear
DLDataSht.Rows("2:1000000").EntireRow.Clear
wkbpath = ThisWorkbook.Path
Set ws_master = Workbooks.Open(wkbpath & "\" & IPWkb)
Shtname = ws_master.Sheets(1).Name
Sht_Count = ws_master.Sheets.Count
For ShtInx = 1 To Sht_Count
Shtname = ws_master.Sheets(ShtInx).Name
Set ws_Data = ws_master.Sheets(ShtInx)
Wkb_1.Activate
Set OrgFl = Wkb_1.Sheets(DestSheetname)
OrgFl.Select
'OrgFl.Cells.Clear
ws_master.Sheets(Shtname).Activate
Application.CutCopyMode = False
ws_Data.Cells.Copy
Tempsht.Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Tempsht.Rows("1:1").EntireRow.Delete
Tempsht.Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("F:F").TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("J:J").TextToColumns Destination:=Range("J1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("M:M").TextToColumns Destination:=Range("M1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("Q:Q").TextToColumns Destination:=Range("Q1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("U:U").TextToColumns Destination:=Range("U1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("G:H").NumberFormat = "MM/DD/YYYY"
TEmpLastRow = Tempsht.Cells(Rows.Count, 3).End(xlUp).Row
Tempsht.Columns("A").Insert: Tempsht.Range("A1") = "Month"
Wkb_1.Activate: Tempsht.Select
Tempsht.Range(Cells(2, "A"), Cells(TEmpLastRow, "A")) = Shtname & "'" & Format(Now(), "YY")
Wkb_1.Activate: Tempsht.Select
Application.CutCopyMode = False
Tempsht.Range(Cells(2, 1), Cells(LR, LC)).Copy
Wkb_1.Activate
DLDataSht.Select
LastRow = DLDataSht.Cells(Rows.Count, 3).End(xlUp).Row
DLDataSht.Range("A" & LastRow + 1).PasteSpecial
Application.CutCopyMode = False
ws_master.Activate
Next
Windows(IPWkb).Close savechanges:=False
End Sub
Sub OutputMdl()
Set Wkb_1 = ThisWorkbook
Set Autosht = Wkb_1.Sheets("Automation")
Set DLDataSht = Wkb_1.Sheets("GLData")
Set SAPdataSht = Wkb_1.Sheets("YFIINTDSRP")
Set Osht = Wkb_1.Sheets("Output File")
Set Tempsht = Wkb_1.Sheets("Temp")
Osht.Rows("1:1000000").EntireRow.Clear
Wkb_1.Activate: Osht.Select
Wkb_1.Activate: DLDataSht.Select
Application.CutCopyMode = False
DLDataSht.Range(Cells(1, 1), Cells(LR, LC)).Copy
Wkb_1.Activate
Osht.Select
Osht.Range("A1").PasteSpecial
Application.CutCopyMode = False
' Osht.Range("O:O").EntireColumn.Delete
Osht.Range("R:V").EntireColumn.Delete
Osht.Range("C:C").EntireColumn.Delete
Osht.Columns("F:F").Insert Shift:=xlToRight
Osht.Range("F1") = "Section"
Osht.Range("F2:F" & LR).Formula = "=VLOOKUP(G2,Mapping!A:B,2,0)"
Osht.Columns("J:J").Insert Shift:=xlToRight
Osht.Range("J1") = "Expense G/L"
Osht.Range("J2:J" & LR).Formula = "=VLOOKUP(G2,Mapping!A:B,2,0)"
Osht.Columns("P:V").Insert Shift:=xlToRight
Osht.Range("P1") = "Vendor Code"
Osht.Range("P2:P" & LR).Formula = "=VLOOKUP(G2,YFIINTDSRP!H:J,3,0)"
Osht.Range("Q1") = "Vendor Name"
Osht.Range("Q2:Q" & LR).Formula = "=VLOOKUP(G2,YFIINTDSRP!H:K,4,0)"
Osht.Range("R1") = "Vendor PAN"
Osht.Range("R2:R" & LR).Formula = "=VLOOKUP(G2,YFIINTDSRP!H:L,5,0)"
Osht.Range("T2:T" & LR).Formula = "=LEFT(S2,4)"
Osht.Range("U2:U" & LR).Formula = "=RIGHT(U2,1)"
Osht.Range("V1") = "WHT Base Amount"
Osht.Range("W1") = "Amount in local curre ncy As per GL"
Osht.Range("Y1") = "Return TDS"
Osht.Range("Z1") = "Return rateS"
Osht.Range("Z2:Z" & LR).Formula = "=Y2/W2*100"
Osht.Range("AA1") = "RPU Base"
Osht.Range("AA2:AA" & LR).Formula = "=-W2"
Osht.Range("AB1") = "RPU TDS"
Osht.Range("AB2:AB" & LR).Formula = "=-Y2"
'Osht.Range("R1") = "Vendor PAN"
'Osht.Range("R2:R" & LR).Formula = "=VLOOKUP(H2,YFIINTDSRP!H:L,5,0)"
Osht.Columns("A:A").Insert Shift:=xlToRight
Osht.Range("A1") = "Working Remark"
Osht.Range("AE1") = "Certifiacte"
Osht.Range("AF1") = "Reason"
Osht.Range("AG1") = "BSRCode"
Osht.Range("AH1") = "Tender Date"
Osht.Range("AI1") = "Challan Sn"
Osht.Range("AJ1") = "SN"
'-----------------------------------------------------------------
'//Creating Output file
Path = ThisWorkbook.Path
Dim OWkb As Workbook
Set OWkb = Workbooks.Add
File_Name = Autosht.Range("D8")
Wkb_1.Sheets("Output File").Copy OWkb.Sheets(OWkb.Sheets.Count)
OWkb.SaveAs Filename:=Path & "\" & File_Name, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
OWkb.Activate: OWkb.Sheets("Output File").Range("A1").Select: OWkb.Save: Windows(File_Name).Close
End Sub
Try the Cleaning process for each sheet.
From the Last Edited Column till the End column (Towards Right).Select and Delete all columns (Ctrl + '-')
From the Last Edited Row till the End Row (Towards Bottom).Select and Delete all rows (Ctrl + '-')
Regarding 'Macro file size': No answer for this other than to suggest:
Export the modules from the 'big' macro workbook
Create a brand new workbook
Import the files from step 1 into the new workbook.
The new workbook will be smaller. If it grows every time you run your code - then that's where you can start to figure out the problem. Run just parts of the code until you can detect what code is changing the file size.
Your next question is how to find slow or lengthy operations. This can be done with code like:
Dim timeDuration As Variant
Dim timeStart As Variant
Dim timeEnd As Varient
timeStart = Timer
'Call a function or subroutine
timeEnd = Timer
Debug.Print "<Method Name> duration: " & CStr(timeEnd - timeStart)
Evaluate the results in the Immediate window
Or, you can put the code within each method and grab timeStart at the top of the method and timeEnd at the bottom.
It is helpful here is to have code that is grouped into focused methods that the above code can surround. The provided code has 4 methods...so that would be the first set of results to look at - and then proceed from there.
Evaluating the code was harder than it needed to be due to coding style. Some suggestions for you to consider:
Option Explicit
There are few VBA guidelines that fall under the category of always, but this is one of them:
Always declare Option Explicit at the top of any module you create in VBA. Option Explicit forces the developer to explicitly declare all variables, constants, and fields before using them within a module.
Declaring Option Explicit at the top of the provided code and invoking 'Debug -> Compile VBA Project' will identify 44 local variables that are used, but never declared and two subroutines that prevent the posted code from compiling (I assume the subroutines exist in another module...just not the one posted).
(Suggestion) The Visual Basice Editor (VBE) will automatically place Option Explicit at the top of new modules by checking 'Tools -> Options... -> Require Variable Declaration'.
Use Meaningful Names
All developers spend far more time reading code that writing it. Consequently, it is exceedingly important that code has variable names that are easily interpreted as to content and functionality. While actively writing code, it is easy to know/remember what variables like LR and/or LC mean. Step away from the code for 24 hours (or read it for the first time on an SO question)...and it's not.
The standard joke is: There are 2 hard problems in computer science: cache invalidation, naming things, and off-by-1 errors. That 'naming things' makes the list underscores both its importance (and difficulty). Long names will not slow down your code...use longer/descriptive names to make your life easier.
(Suggestion)Use names that are at least three characters but preferably full words that convey some meaning. Consider the name from the perspective of a first-time reviewer.
Manage variable Scope
This is related to using Option Explicit. There are 3 variable scopes in VBA: Global, Module, and Local. Some variables names in this code are repeated/used in several subroutines. These variables should be declared explicitly at the top of the module (Module Scope).
Look at how variable Wkb_1 is used. It is declared in Macro_Step_1 but used (without a declaration) in the next 3 subroutines. It is a Workbook object in the Macro_Step_1 (by declaration), but is a Variant in all subsequent uses because it is not explicitly declared. Further, it is assigned the Global ThisWorkbook object. ThisWorkbook should be used directly and Wkb_1 can be deleted. And, relating back to 'Use Meaningful Names', using Wkb_1 obscures the fact (further down the procedure) that it represents the ThisWorkbook object. wkbpath = ThisWorkbook.Path is much more clear than wkbpath = Wkb_1.Path.
(Suggestion) Review all your variables' scope and declare them in the appropriate locations.
Don't Repeat Yourself (DRY)
If you find yourself with a workflow of 'Copy - Paste - change a string', it is time to consider how to capture the code in a procedure. This will make your code easier to read, understand, and sometimes...faster depending on the operations involved.
The code
Tempsht.Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Was created using the above workflow 6 times. The entire wall of copied code can be replaced with:
GiveThisOperationAName "D", "F", "J", "M", "Q", "U"
Where GiveThisOperationAName is:
Private Sub GiveThisOperationAName(ParamArray columnLetters() As Variant)
Dim tempWorksheet As Worksheet
Set tempWorksheet = ThisWorkbook.Sheets("Temp")
Dim columnLetter As Variant
For Each columnLetter In columnLetters
tempWorksheet.Columns(columnLetter & ":" & columnLetter).TextToColumns _
Destination:=Range(columnLetter & "1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Next
End Sub
(Suggestion) There are other areas of opportunity like this. Removing duplication will make your code easier to read/understand, easier to maintain/modify, and easier to instrument for performance testing.
I am new in VBA coding and and am trying to convert text in all sheets except one to text but have not achieved success. I have text in column A of each sheet and number of rows might differ.
This is what my code looks like
Sub text_to_column()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim arr() As Variant, i As Long, nrCol As Long
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Summary" Then
ws.Select
nrCol = 20
ReDim arr(1 To nrCol) As Variant
For i = 1 To nrCol
arr(i) = Array(i, 1)
Next
Selection.TextToColumns _
Destination:=Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:="^", _
FieldInfo:=arr, _
TrailingMinusNumbers:=True
End If
Next ws
End Sub
Please Guide.
Try this code
Sub Test()
Dim a, x, ws As Worksheet, r As Long
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Summary" Then
For r = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row
x = Split(ws.Cells(r, 1).Value, "^")
ws.Cells(r, 2).Resize(, UBound(x) + 1).Value = x
Next r
End If
Next was
End Sub
And as for your approach, you can use such a code
Sub TextToColumns()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Summary" Then
Application.DisplayAlerts = False
ws.Columns(1).TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="^", FieldInfo:=Array(Array(1, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = True
End If
Next was
End Sub
I have this code in which when I click on the button I am able to format the excel data, filter it, delete unnecessary data and then create Pivot table and Chart on a new sheet and rename the sheet as Summary. The problems I am having are:
1.) This work well on all the files I run it on, except one particular file, it run without error, but it doe not create the Pivot Table and it does not create the Chart.
2.) The pie chart codes are recorded, from excel 2013 and it will not run well in excel 2010,(see Sub Pichrt) below, so I a have to create another recorded macros in excel 2010 for my co-workers who are still using excel 2010, is there a way to make 1 code run for both 2010 and 2013, this happen only in the part where it need to create the pie chart. Any help will be greatly appreciated. Sorry for too long code, most are recorded as I am not an expert.
Thank you.
Sub OpenIt()
myFile = Application.GetOpenFilename(, , "Browse forWorkbook")
Workbooks.Open myFile
Call KeepOnlyAtSymbolRows
End Sub
Sub KeepOnlyAtSymbolRows()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Abstraction Data Extract")
lastRow = ws.Range("J" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("J1:J" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="<>*Yes*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
lastRow = ws.Range("I" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("I1:I" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="<>*C=Complete*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
Call Format
End Sub
Sub Format()
Dim Found As Range
Dim LastRowColumnA As Long
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim lastRow As Long
Dim LastCol As Long
Rows("1:1").Select
Selection.AutoFilter
Set Found = Rows(1).Find(what:="Comments", LookIn:=xlValues,
lookat:=xlWhole)
If Not Found Is Nothing Then Found.Value = "Differences"
Columns("N:O").Select
Selection.Style = "Currency"
Columns("N:N").Select
Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("O:O").Select
Selection.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("F:F").Select
Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "m/d/yyyy"
Columns("L:L").Select
Selection.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "m/d/yyyy"
Columns("G:G").Select
Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "m/d/yyyy"
LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row
Range("S2:S" & LastRowColumnA).Formula = "=RC[-5]-RC[-4]"
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PivotTable").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True
Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("Abstraction Data Extract")
'Define Data Range
lastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(lastRow, LastCol)
'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=PRange). _
CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
TableName:="OnePivotTable")
'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable _
(TableDestination:=PSheet.Cells(1, 1), TableName:="OnePivotTable")
'Insert Row Fields
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("DRG Mismatch
Reason")
.Orientation = xlRowField
.Position = 1
'.Caption = "Mismatch Reason"
.PivotItems("(blank)").Visible = False
ActiveSheet.PivotTables("OnePivotTable").CompactLayoutRowHeader = "Mistmatch
Reason"
On Error GoTo 0
End With
'Insert Data Field
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Final DRG
Reimbursement")
.Orientation = xlDataField
.Position = 1
.Calculation = xlPercentOfTotal
.NumberFormat = "0.00%"
.Name = "Percent of Total"
End With
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Final DRG
Reimbursement")
.Orientation = xlDataField
.Position = 2
.Function = xlCount
.NumberFormat = "#,##0"
.Name = "Count"
End With
'Insert Data Field
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Final DRG
Reimbursement")
.Orientation = xlDataField
.Position = 3
.Function = xlSum
.NumberFormat = "$#,##0"
.Name = "Final DRG Reimbursement "
End With
'Insert Data Field
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Working DRG
Reimbursement")
.Orientation = xlDataField
.Position = 4
.Function = xlSum
.NumberFormat = "$#,##0"
.Name = "Working DRG Reimbursement "
End With
'Insert Data Field
On Error Resume Next
With ActiveSheet.PivotTables("OnePivotTable").PivotFields("Differences")
.Orientation = xlDataField
.Position = 5
.Function = xlSum
.NumberFormat = "$#,##0"
.Name = "Differences "
End With
'Format Pivot
TableActiveSheet.PivotTables("SalesPivotTable").ShowTableStyleRowStripes =
True
ActiveSheet.PivotTables("SalesPivotTable").TableStyle2 = "PivotStyleMedium9"
Sheets("PivotTable").Name = "Summary"
Call PiChrt
End Sub
Sub PiChrt()
Range("B4:C10").Select
ActiveSheet.Shapes.AddChart2(251, xlPie).Select
ActiveChart.SetSourceData Source:=Range("Summary!$B$2:$G$11")
ActiveSheet.Shapes("Chart 1").IncrementLeft -143.25
ActiveSheet.Shapes("Chart 1").IncrementTop 50.25
ActiveChart.SetElement (msoElementDataLabelBestFit)
ActiveChart.SetElement (msoElementDataLabelInsideEnd)
ActiveChart.FullSeriesCollection(1).DataLabels.Select
With Selection.Format.TextFrame2.TextRange.Font
.BaselineOffset = 0
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
End With
ActiveChart.ChartArea.Select
ActiveSheet.Shapes("Chart 1").ScaleHeight 1.7239585156, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes("Chart 1").ScaleHeight 1.1208461201, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes("Chart 1").ScaleWidth 1.0416666667, msoFalse, _
msoScaleFromTopLeft
ActiveWindow.ScrollRow = 15
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
ActiveWorkbook.ShowPivotTableFieldList = False
End Sub
I haven't checked your complete code for bugs, but the non-creation of a pivot table might be due to the fact that, I don't know for what reason, the PivotRange has to be encoded as a STRING format, using a R1C1 reference style.
This gives:
Dim PRange As string
'Define data range
lastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
PRange = DSheet.Name & "!" & DSheet.Range(DSheet.Cells(1,1), DSheet.Cells(LastRow, LastCol)).Address(ReferenceStyle:=x1A1)
'Define Pivot Cache
'rest of your code
I want to create 14 pivot table.I have recorded a macro.My macro code is given below.If I want to apply for loop to create 14 pivot tables, how to do that?
I am a beginner so unable to understand how to apply for loop to automate this recorded code?
My macro is given below:
Sub Macro1()
'
' Macro1 Macro
'
'
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Sheets.Add
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Current Fleet Comparison!R1C1:R1048576C41", Version:=xlPivotTableVersion14). _
CreatePivotTable TableDestination:="Sheet1!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion14
Sheets("Sheet1").Select
Cells(3, 1).Select
ActiveWorkbook.ShowPivotTableFieldList = True
With ActiveSheet.PivotTables("PivotTable1").PivotFields("AircraftType")
.Orientation = xlPageField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("AircraftType"), "Count of AircraftType", xlCount
With ActiveSheet.PivotTables("PivotTable1").PivotFields("OperatorArea")
.Orientation = xlColumnField
.Position = 1
End With
Range("A1:F5").Select
Selection.Copy
Range("A8").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable2").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable2").PivotFields("AircraftType").CurrentPage _
= "A318"
Range("A15").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable3").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable3").PivotFields("AircraftType").CurrentPage _
= "A319"
Range("A22").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable4").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable4").PivotFields("AircraftType").CurrentPage _
= "A320"
ActiveWindow.SmallScroll Down:=15
Range("A29").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable5").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable5").PivotFields("AircraftType").CurrentPage _
= "A321"
Range("A36").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable6").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable6").PivotFields("AircraftType").CurrentPage _
= "ATR 42"
ActiveWindow.SmallScroll Down:=3
Range("A43").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable7").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable7").PivotFields("AircraftType").CurrentPage _
= "ATR 72"
ActiveWindow.SmallScroll Down:=9
Range("A50").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable8").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable8").PivotFields("AircraftType").CurrentPage _
= "CRJ100 Regional Jet"
ActiveWindow.SmallScroll Down:=3
Range("A57").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable9").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable9").PivotFields("AircraftType").CurrentPage _
= "CRJ200 Regional Jet"
ActiveWindow.SmallScroll Down:=12
Range("A65").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable10").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable10").PivotFields("AircraftType"). _
CurrentPage = "Q100"
Range("A72").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable11").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable11").PivotFields("AircraftType"). _
CurrentPage = "Q200"
ActiveWindow.SmallScroll Down:=9
Range("A79").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable12").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable12").PivotFields("AircraftType"). _
CurrentPage = "Q300"
ActiveWindow.SmallScroll Down:=9
Range("A86").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable13").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable13").PivotFields("AircraftType"). _
CurrentPage = "Q400"
ActiveWindow.SmallScroll Down:=9
Range("A94").Select
ActiveSheet.Paste
ActiveSheet.PivotTables("PivotTable14").PivotFields("AircraftType"). _
ClearAllFilters
ActiveSheet.PivotTables("PivotTable14").PivotFields("AircraftType"). _
CurrentPage = "Q400 NextGen"
End Sub
I am a beginner so unable to understand how to apply for loop to automate this recorded code?
In the following macro, since your sample code didn't contain all 14 pages to be used for the pagefield, you'll need to complete the list being assigned to varPages before running the macro...
'Force the explicit declaration of variables
Option Explicit
Sub CreatePivotTables()
'Declare the variables
Dim varPages As Variant
Dim objPivotCache As PivotCache
Dim objPivotTable As PivotTable
Dim wksSource As Worksheet
Dim rngSource As Range
Dim CurrRow As Long
Dim i As Long
'Turn off screen updating to speed up macro
Application.ScreenUpdating = False
'Assign the source worksheet for the pivottables to wksSource
Set wksSource = Worksheets("Current Fleet Comparison")
'Assign the source range for the pivottables to rngSource
Set rngSource = wksSource.Range("A1").CurrentRegion
'Create the pivotcache for the pivottables
Set objPivotCache = ActiveWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=rngSource)
'Add new worksheet for the pivottables
Sheets.Add
'Assign the list of pages for the pagefield to varPages (add the remaining pages)
varPages = Array("A318", "A319", "A320", . . .)
CurrRow = 3
For i = 1 To 14
'Create the pivottable
Set objPivotTable = ActiveSheet.PivotTables.Add( _
PivotCache:=objPivotCache, _
TableDestination:=Cells(CurrRow, "A"), _
TableName:="PivotTable" & i)
'Add the fields for the pivottable
With objPivotTable
.AddDataField .PivotFields("AircraftType"), "Count of AircraftType", xlCount
.PivotFields("OperatorArea").Orientation = xlColumnField
With .PivotFields("AircraftType")
.Orientation = xlPageField
.CurrentPage = varPages(i - 1)
End With
With .TableRange2
CurrRow = .Offset(.Rows.Count + 4).Row
End With
End With
Next i
'Show the pivottable field list
ActiveWorkbook.ShowPivotTableFieldList = True
'Turn screen updating back on
Application.ScreenUpdating = True
End Sub
I have run into an issue, I have a script thanks to several members here has allowed me to import directly from a file into a workbook. With that same script I've incorporated the ability to organize by color red on top, and green underneith. I thought I could write the code to make it so that yellow would be in the middle myself, but it doesn't take into concideration it seems the difference between yellow and red, although I thought I did make that difference noticable though the script.
If someone can look at this and tell me where I am going wrong it would be greatly apprecaited.
This is what I get now for an end result, the yellow is on the bottom of the sheet btw after importing.
The code for some reason isn't reading right, so attached is also a link to the sheet, with the added file to import.
Zip File
or the files seperate here...
Sheet
CSV
Here is my code:
Option Explicit
Sub Update_POT()
Dim wsPOD As Worksheet
Dim wsPOT As Worksheet
Dim wsPOA As Worksheet
Dim cel As Range
Dim lastrow As Long, fstcell As Long, i As Long, Er As Long, lstCol As Long, lstRow As Long, strFile As String
Set wsPOD = Sheets("PO Data")
Set wsPOT = Sheets("PO Tracking")
Set wsPOA = Sheets("PO Archive")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With wsPOD
.Columns("A:AB").ClearContents
.Range("Y1").Formula = "=COUNTIFS('PO Tracking'!$D:$D,$C1,'PO Tracking'!$C:$C,$D1,'PO Tracking'!$F:$F,$G1)"
.Range("Z1").Formula = "=IF($M1,"""",""Different"")"
.Range("AA1").Formula = "=IF(ISBLANK($C1),0,1)"
.Range("AB1").Formula = "=IF($O1,""Full"","""")"
End With
strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please selec text file...")
With wsPOD.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=wsPOD.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
With wsPOD
'first bring columns F:G up to match their line
For Each cel In Intersect(.UsedRange, .UsedRange.Offset(5), .Columns(6))
If cel = vbNullString And cel.Offset(, -2) <> vbNullString Then
.Range(cel.Offset(1), cel.Offset(1, 1)).Copy cel
cel.Offset(1).EntireRow.Delete
End If
Next
'now fil columns A:D to match PO Date and PO#
For Each cel In Intersect(.UsedRange, .UsedRange.Offset(5), .Columns(1))
If cel = vbNullString And cel.Offset(, 5) <> vbNullString Then
.Range(cel.Offset(-1), cel.Offset(-1, 3)).Copy cel
End If
Next
lastrow = wsPOD.Cells(Rows.Count, "J").End(xlUp).Row
fstcell = wsPOD.Cells(Rows.Count, "N").End(xlUp).Row
wsPOD.Range("Y1:AB1").Copy wsPOD.Range("M" & fstcell & ":P" & lastrow)
wsPOD.Range("M:P").Calculate
End With
With Intersect(wsPOD.UsedRange, wsPOD.Columns("P"))
.AutoFilter 1, "<>Full"
With Intersect(.Offset(2).EntireRow, .Parent.Range("A:P"))
.EntireRow.Delete
End With
.AutoFilter
End With
With Intersect(wsPOD.UsedRange, wsPOD.Columns("N"))
.AutoFilter 1, "<>Different"
With Intersect(.Offset(2).EntireRow, .Parent.Range("A:P"))
.EntireRow.Delete
End With
.AutoFilter
End With
'Final Adjustments before transfering over to PO Tracking.
With wsPOD
.AutoFilterMode = False
lastrow = wsPOD.Cells(Rows.Count, "A").End(xlUp).Row
Intersect(.UsedRange, .Range("A4:A" & lastrow)).Cut .Range("Q3")
Intersect(.UsedRange, .Columns("D")).Cut .Range("R1")
Intersect(.UsedRange, .Columns("C")).Cut .Range("S1")
Intersect(.UsedRange, .Columns("B")).Cut .Range("T1")
Intersect(.UsedRange, .Columns("G")).Cut .Range("U1")
Intersect(.UsedRange, .Columns("F")).Cut .Range("V1")
End With
With wsPOD
wsPOD.Columns("A:P").ClearContents
lastrow = wsPOD.Cells(Rows.Count, "Q").End(xlUp).Row
wsPOD.Range("Q3:V" & lastrow).Copy wsPOT.Cells(Rows.Count, "B").End(xlUp).Offset(1)
End With
'Format PO Tracking
With wsPOT
.Range("Q1:U1").Copy
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("V1:X1").Copy .Range("H3:J" & lastrow)
.Range("N2:O2").Copy .Range("N3:O" & lastrow)
.Range("P1:V1").Copy
.Range("B3:H" & lastrow).PasteSpecial xlPasteFormats
.Range("K3:K" & lastrow).Borders.Weight = xlThin
lastrow = .Cells(.Rows.Count, "H").End(xlUp).Row
.Range("H:J").Calculate
.Sort.SortFields.Clear
'Sort PO Tracking
'Sort Reds
.Sort.SortFields.Add(.Range("J3:J" & lastrow), _
xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
IconSets(4).Item(1)
.Sort.SortFields.Add Key:=Range( _
"J3:J30" & lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
'Sort Yellows
.Sort.SortFields.Add(.Range("I3:I" & lastrow), _
xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
IconSets(4).Item(2)
.Sort.SortFields.Add Key:=Range( _
"I3:I" & lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
'Sort Greens
.Sort.SortFields.Add(.Range("I3:I" & lastrow), _
xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
IconSets(4).Item(3)
.Sort.SortFields.Add Key:=Range( _
"I3:I" & lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With .Sort
.SetRange wsPOT.Range("B2:K" & lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
With wsPOD
wsPOD.Columns("Q:X").ClearContents
wsPOD.Cells(1, 25).Value = "=COUNTIFS('PO Tracking'!$D:$D,$C1,'PO Tracking'!$C:$C,$D1,'PO Tracking'!$F:$F,$G1)"
wsPOD.Cells(1, 27).Value = "=IF(ISBLANK($C1),0,1)"
wsPOD.Range("Y1:AB1").Copy wsPOD.Range("M5:P5")
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub
You have to remove the line
.Sort.SortFields.Add Key:=Range( _
"I3:I" & lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
in
'Sort Yellows
.Sort.SortFields.Add(.Range("I3:I" & lastrow), _
xlSortOnIcon, xlAscending, , xlSortNormal).SetIcon Icon:=ActiveWorkbook. _
IconSets(4).Item(2)
.Sort.SortFields.Add Key:=Range( _
"I3:I" & lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
You cannot have have the same duplicate sort conditions for both Yellow and Green in the same column. Remove that line and try again.