Excel Code Dumpster

What the heck is this? Well, this is more for me than you... 
Like Albus Dumbledore, this is my Pensieve - the extraction and long-term storage of my memories, in this case: VBA code. 

When I can't remember how to CreateObject for an ADODB connection, I can just search the page for "ADODB". It's in here somewhere.  Where's the last column on the right again? Oh, yeah... just search for "lastcol".  It's in here somewhere.
Application.Calculation = xlManual 
Application.Calculation = xlAutomatic 
Application.ScreenUpdating = True 
Application.DisplayStatusBar = True 
Application.StatusBar = "500 rows completed..." 
Application.ScreenUpdating = False 
thisFOCUSrow = thisFOCUSrow + 1 
BOTTOM STATUS COUNTER BY ARITHMETIC 
'bottom screen counter by 1000's 
x = Int(thisFOCUSrow / 1000) 
y = thisFOCUSrow / 1000  
If x = y Then 
 Application.ScreenUpdating = True 
 Application.DisplayStatusBar = True 
 Application.StatusBar = "Level 1: " & x & "000 rows completed..." 
 Application.ScreenUpdating = False 
 End If 
- Opening other Excel files to copy data (data library). 
Private Sub button_LOAD_Click() 
 ControlWB = ThisWorkbook.Name 
 FILEPath = ActiveSheet.Range("B31").Value 
 LOBFile = ActiveSheet.Range("B32").Value 
 COREFile = ActiveSheet.Range("B33").Value 
 Workbooks.Open Filename:=FILEPath & LOBFile, ReadOnly:=True 
With Sheets("GraftedLOB") 
 lastGraftedLOBrow = .Range("B" & .Rows.Count).End(xlUp).Row 
End With 
With Sheets("GraftedLOB").Range("B:B") 
 Set FndRng = .Find(What:=thisComponent, LookIn:=xlValues, LookAt:=xlWhole) 
 If Not FndRng Is Nothing Then ' <-- Find was successful 
 topMOrow = FndRng.Row SameCOMP = True
Else SameCOMP = False 
 End If 
End With 
Workbooks.Open Filename:=FILEPath & COREFile, ReadOnly:=True 
With Sheets("ShippedItems") 
lastSHIPPEDrow = .Range("B" & .Rows.Count).End(xlUp).Row 
End With 
Workbooks(ControlWB).Activate Workbooks(LOBFile).Sheets("GraftedLOB").Range("A1:Z" & lastGraftedLOBrow).Copy Destination:=Sheets("LOB").Range("A1") Workbooks(LOBFile).Sheets("GraftedLOB").Range("A1:Z" & lastGraftedLOBrow).Copy Destination:=Sheets("OrigReleases").Range("A1") Workbooks(COREFile).Sheets("ShippedItems").Range("A1:Z" & lastSHIPPEDrow).Copy Destination:=Sheets("ShippedItems").Range("A1") Workbooks(COREFile).Sheets("Inventory").Range("A1:Z" & lastINVrow).Copy Destination:=Sheets("Inventory").Range("A1") Workbooks(COREFile).Sheets("SchedReceipts").Range("A1:AF" & lastRECEIPTSrow).Copy Destination:=Sheets("SchedReceipts").Range("A1") Workbooks(COREFile).Sheets("MOHeads").Range("A1:Z" & lastMOCOMPSrow).Copy Destination:=Sheets("MOData").Range("A1") Workbooks(COREFile).Sheets("MOComps").Range("A1:K" & lastMOCOMPSrow).Copy Destination:=Sheets("MOData").Range("J1") Workbooks(COREFile).Close savechanges:=False Workbooks(LOBFile).Close savechanges:=False - Adding a Rowkey column with Copy/Paste Values 'ROWKEY Re-sorting row... Application.ScreenUpdating = False With Sheets("LOB") lastLOBrow = .Range("B" & .Rows.Count).End(xlUp).Row End With Sheets("LOB").Range("T1").Value = "Rowkey" Sheets("LOB").Range("T2").Value = 1 Sheets("LOB").Range("T3").Formula = "=T2+1" Sheets("LOB").Range("T3").Copy Destination:=Sheets("LOB").Range("T4:T" & lastLOBrow) Sheets("LOB").Range("T1:T" & lastLOBrow).Copy ActiveSheet.Range("S1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("LOB").Columns("T:T").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft ActiveSheet.Range("T1").Select ActiveSheet.Range("M1").Value = "x" ActiveSheet.Range("N1").Value = "x" - Copy - Destination copy methods Sheets("LOB").Range("B1:C" & lastLOBrow).Copy Destination:=Sheets("Scratch").Range("A1") Sheets("ShippedItems").Range("B1:B" & lastSHIPPEDrow).Copy Destination:=Sheets("Scratch").Range("J1") Sheets("ShippedItems").Range("F1:F" & lastSHIPPEDrow).Copy Destination:=Sheets("Scratch").Range("K1") - Programming PIVOT TABLES, then copy pasting values and removing the table 'BOTTOM of main data With Sheets("Shipments") lastSHIPPEDrow = .Range("B" & .Rows.Count).End(xlUp).Row - 1 End With ActiveSheet.Range("M1").Select thisrange = "Scratch!$J$1:$K$" & lastSHIPPEDrow 'dynamic range for the pivot's "source data" Sheets("Scratch").Select ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ thisrange, Version:=6).CreatePivotTable TableDestination:= _ "Scratch!R1C13", TableName:="PivotTable3", DefaultVersion:=6 With ActiveSheet.PivotTables("PivotTable3").PivotFields("CO Line") .Orientation = xlRowField .Position = 1 End With ActiveSheet.PivotTables("PivotTable3").AddDataField ActiveSheet.PivotTables( _ "PivotTable3").PivotFields("QTY Shipped"), "Sum of QTY Shipped", xlSum 'BOTTOM of the new Pivot Table With Sheets("Scratch") lastPIVOTrow = .Range("M" & .Rows.Count).End(xlUp).Row - 1 End With 'Copy/Paste values of pivot table to new columns and delete the old columns (make sure you have room to delete more columns than the pivot table) ActiveSheet.Range("M1:N" & lastPIVOTrow).Select Selection.Copy ActiveSheet.Range("G1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ActiveSheet.Range("F1").Select Application.CutCopyMode = False Sheets("Scratch").Columns("I:P").Delete Shift:=xlToLeft 'VLOOKUP the pivot table results into the main data thisformula = "=IFERROR(VLOOKUP(A2,$G$2:$H$" & lastPIVOTrow & ",2,FALSE),0)" 'better to build up the formula in a string first for the dynamic bottom of the range ActiveSheet.Range("C2").Formula = thisformula ActiveSheet.Range("C2").Copy Destination:=ActiveSheet.Range("C3:C" & lastLOBrow) ActiveSheet.Range("D2").Formula = "= B2 - C2" ActiveSheet.Range("D2").Copy Destination:=ActiveSheet.Range("D3:D" & lastLOBrow) 'Copy and paste values again ActiveSheet.Range("D2:D" & lastLOBrow).Select Selection.Copy ActiveSheet.Range("B2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Range("A1").Select 'Remove Duplicates Sheets("Scratch").Columns("C:J").Delete Shift:=xlToLeft 'remove final dupes ActiveSheet.Range("$A$1:$B$" & lastLOBrow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes ActiveSheet.Range("A1").Select With Sheets("Scratch") lastSCRATCHrow = .Range("A" & .Rows.Count).End(xlUp).Row - 1 End With Sheets("LOB").Select thisformula = "=IFERROR(VLOOKUP(B2,Scratch!$A$2:$B$" & lastSCRATCHrow & ",2,FALSE),999999)" ActiveSheet.Range("M2").Formula = thisformula ActiveSheet.Range("M2").Copy Destination:=ActiveSheet.Range("M3:M" & lastLOBrow) ActiveSheet.Range("M2:M" & lastLOBrow).Select Selection.Copy ActiveSheet.Range("L2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Range("M2:M" & lastLOBrow).ClearContents 'resort LOB largest in L ActiveWorkbook.Worksheets("LOB").Sort.SortFields.Clear ActiveWorkbook.Worksheets("LOB").Sort.SortFields.Add Key:=Range("L2:L" & lastLOBrow) _ , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("LOB").Sort .SetRange Range("A2:Z" & lastLOBrow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ActiveSheet.Range("L2").Select 'clear the 999999s thisrow = 2 thisLcolumn = ActiveSheet.Range("L2").Value If thisLcolumn = 999999 Then Do While thisLcolumn = 999999 thisrow = thisrow + 1 thisLcolumn = ActiveSheet.Range("L" & thisrow).Value Loop End If ActiveSheet.Range("L" & thisrow & ":L" & lastLOBrow).Copy Destination:=ActiveSheet.Range("C" & thisrow) ActiveSheet.Range("C:C").Select With Selection .HorizontalAlignment = xlCenter End With ActiveWorkbook.Worksheets("LOB").Sort.SortFields.Clear ActiveWorkbook.Worksheets("LOB").Sort.SortFields.Add Key:=Range("C2:C" & lastLOBrow) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("LOB").Sort .SetRange Range("A2:Z" & lastLOBrow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ActiveSheet.Range("C1").Value = "QTY Remaining" ActiveSheet.Range("C2").Select 'remove the zero rows thisCcolumn = ActiveSheet.Range("C2").Value If thisCcolumn = 0 Then Do While thisCcolumn = 0 thisrow = thisrow + 1 thisCcolumn = ActiveSheet.Range("C" & thisrow).Value Loop bottomDELrow = thisrow - 1 topDELrow = 2 thisrange = "A" & topDELrow & ":Z" & bottomDELrow ActiveSheet.Range(thisrange).Select Selection.Delete Shift:=xlUp ActiveSheet.Range("L2:L" & lastLOBrow).Select Selection.ClearContents ActiveSheet.Range("A1").Select End If Private Sub button_LOBSTATUS_Click() thisrun = ActiveSheet.Range("B7").Value Select Case thisrun Case "FULLRUN" Call The_N10_RUN Call The_N18_RUN Case "ONLY-N10", "N10-FRP7", "N10-FRP8", "N10-FRP9", "N10-FRP10", "N10-FRP11", "N10picks" Call The_N10_RUN Case "ONLY-N18", "N18picks" Call The_N18_RUN End Select End Sub 'SORT BY COMPONENTS (to be put back together later) ActiveWorkbook.Worksheets("LOB").Sort.SortFields.Clear ActiveWorkbook.Worksheets("LOB").Sort.SortFields.Add Key:=Range("H2:H" & lastLOBrow), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("LOB").Sort.SortFields.Add Key:=Range("O2:O" & lastLOBrow), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortTextAsNumbers With ActiveWorkbook.Worksheets("LOB").Sort .SetRange Range("A2:T" & lastLOBrow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'Go find matching SCHED_RECEIPTS ********************************************************************************************* With Sheets("SchedReceipts").Range("H:H") Set FndRng = .Find(What:=thisComponent, LookIn:=xlValues, LookAt:=xlWhole) If Not FndRng Is Nothing Then ' <-- Find was successful topMOrow = FndRng.Row BUYpart = 1 sameRCV = True Else sameRCV = False End If End With 'Centering ActiveSheet.Range("K:K,M:N,Q:R,U:W,Y:Y").HorizontalAlignment = xlCenter End With ThousandsCount = Int(bottomCOMProw / 5000) Application.ScreenUpdating = True Select Case ThousandsCount Case 1 Application.StatusBar = "N10: 5000 of " & lastLOBrow & " rows..." Case 2 Application.StatusBar = "N10: 10000 of " & lastLOBrow & " rows..." Case 3 Application.StatusBar = "N10: 15000 of " & lastLOBrow & " rows..." Case 4 Application.StatusBar = "N10: 20000 of " & lastLOBrow & " rows..." Case 5 Application.StatusBar = "N10: 25000 of " & lastLOBrow & " rows..." Case 6 Application.StatusBar = "N10: 30000 of " & lastLOBrow & " rows..." Case 7 Application.StatusBar = "N10: 35000 of " & lastLOBrow & " rows..." Case 8 Application.StatusBar = "N10: 40000 of " & lastLOBrow & " rows..." Case 9 Application.StatusBar = "N10: 45000 of " & lastLOBrow & " rows..." Case 10 Application.StatusBar = "N10: 50000 of " & lastLOBrow & " rows..." Case 11 Application.StatusBar = "N10: 55000 of " & lastLOBrow & " rows..." Case 12 Application.StatusBar = "N10: 60000 of " & lastLOBrow & " rows..." Case 13 Application.StatusBar = "N10: 65000 of " & lastLOBrow & " rows..." Case 14 Application.StatusBar = "N10: 70000 of " & lastLOBrow & " rows..." Case 15 Application.StatusBar = "N10: 75000 of " & lastLOBrow & " rows..." Case 16 Application.StatusBar = "N10: 80000 of " & lastLOBrow & " rows..." Case 17 Application.StatusBar = "N10: 85000 of " & lastLOBrow & " rows..." Case 18 Application.StatusBar = "N10: 90000 of " & lastLOBrow & " rows..." Case 19 Application.StatusBar = "N10: 95000 of " & lastLOBrow & " rows..." Case 20 Application.StatusBar = "N10: 100000 of " & lastLOBrow & " rows..." End Select Application.ScreenUpdating = False Sheets("LOB").Range("L2").Formula = "=IFERROR(VLOOKUP(H2,Inventory!$B$2:$E$" & lastINVrow & ",4,FALSE),""X"")" Sheets("LOB").Range("L2").Copy Destination:=Sheets("LOB").Range("L3:L" & lastLOBrow) Application.ScreenUpdating = True 'Sort Shipped Items With Sheets("ShippedItems") lastSHIPPEDrow = .Range("B" & .Rows.Count).End(xlUp).Row End With With Sheets("ShippedItems").Range("A:A") Set FndRng = .Find(What:="N18", LookIn:=xlValues, LookAt:=xlWhole) If Not FndRng Is Nothing Then ' <-- Find was successful topN18row = FndRng.Row Else topN18row = 0 End If End With Sheets("ShippedItems").Range("A1:R1").Copy Destination:=Sheets("ShippedN18").Range("A1") Sheets("ShippedItems").Range("A" & topN18row & ":R" & lastSHIPPEDrow).Copy Destination:=Sheets("ShippedN18").Range("A2") thisrange = "A" & topN18row & ":Z" & lastSHIPPEDrow Sheets("ShippedItems").Select HopOverDo: ActiveSheet.Range("G4").Activate 'remove unrelated columns Sheets("SummaryN10").Select ActiveSheet.Columns("O:O").Select Selection.Delete Shift:=xlToLeft ActiveSheet.Columns("P:Y").Select Selection.Delete Shift:=xlToLeft ActiveSheet.Columns("Q:R").Select Selection.Delete Shift:=xlToLeft 'convert status to text ActiveSheet.Range("P2:P" & lastLOBrow).Select Selection.NumberFormat = "@" ActiveSheet.Range("R2").Formula = "=IF(LEFT(P2,1)=""4"",P2,IF(P2=""STOCK"",2,1))" ActiveSheet.Range("R2").Copy Destination:=ActiveSheet.Range("R3:R" & lastLOBrow) ActiveSheet.Range("R2:R" & lastLOBrow).Select Selection.Copy ActiveSheet.Range("Q2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Columns("R:R").Select Selection.Delete Shift:=xlToLeft ActiveSheet.Range("P1").Value = "Index" ActiveSheet.Range("Q1").Value = "STATUS" 'Pivot table the STOCKs DATES and MRP RECs thisrange = "SummaryN10!$O$1:$Q$" & lastLOBrow thislocation = "SummaryN10!R1C24" ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ thisrange, Version:=6).CreatePivotTable TableDestination _ :=thislocation, TableName:="PivotTable3", DefaultVersion:=6 With ActiveSheet.PivotTables("PivotTable3").PivotFields("CO Line") .Orientation = xlRowField .Position = 1 End With ActiveSheet.PivotTables("PivotTable3").AddDataField ActiveSheet.PivotTables( _ "PivotTable3").PivotFields("STATUS"), "Count of STATUS", xlCount With ActiveSheet.PivotTables("PivotTable3").PivotFields("Count of STATUS") .Caption = "Max of STATUS" .Function = xlMax End With 'copy values only With Sheets("SummaryN10") lastDATESrow = .Range("X" & .Rows.Count).End(xlUp).Row - 1 End With ActiveSheet.Range("S1").Value = "COLines" ActiveSheet.Range("T1").Value = "Status" ActiveSheet.Range("X2:Y" & lastDATESrow).Select Selection.Copy ActiveSheet.Range("S2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Columns("V:AB").Select Selection.Delete Shift:=xlToLeft ActiveSheet.Columns("O:R").Select Selection.Delete Shift:=xlToLeft With Sheets("SummaryN10") lastDATESrow = .Range("O" & .Rows.Count).End(xlUp).Row End With ActiveSheet.Range("R2").Formula = "=IF(P2=2,""STOCK"",IF(P2=1,""MRP REC"",P2))" ActiveSheet.Range("R2").Copy Destination:=ActiveSheet.Range("R3:R" & lastDATESrow) ActiveSheet.Range("R2:R" & lastDATESrow).Select Selection.Copy ActiveSheet.Range("Q2").Select Private Sub GETbutton_Click() ' Declare DB Server and logon credentials Dim datsrc As String Dim uname As String Dim upass As String Dim lastrow As Long datsrc = "CP00" uname = "CPSYS" upass = "xxxxxxxx" Application.ScreenUpdating = False ' Is there an Order Number? ActiveSheet.Range("b2").Select thisOrder = ActiveCell.Value space_padded_order_num = Right(" " & thisOrder, 7) If ActiveCell.Value = 0 Then Exit Sub End If ' Clear Data sheet before update Sheets("Sheet2").Select ActiveSheet.Columns("A:O").Select Selection.ClearContents Selection.NumberFormat = "General" ActiveSheet.Range("a1").Select Sheets("Sheet1").Select ActiveSheet.Range("a2:b2").Select Selection.ClearContents ActiveSheet.Range("b2").Select ActiveSheet.Range("A1:O1").Borders.Color = vbWhite ActiveSheet.Range("A1:O1").Borders.LineStyle = xlContinuous ActiveSheet.Range("b2").Interior.Color = vbWhite Call Col_Headings 'took out T01.CDACQT - quantity ordered at the line level. Replaced T03.ADACQT (MBADREP) qty ordered at the release level ' Execute query to iSeries system On Error Resume Next Set conn = CreateObject("ADODB.Connection") conn.Open "Provider=IBMDA400; Force Translate = 0;" & "Data Source=" & datsrc & ";" & "User ID=" & uname & ";" & "Password=" & upass & ";" Sql = "SELECT T02.CUSNO, T02.CUSNM, T04.C6A3CD, T01.CDCVNB, T01.CDKTNB, T01.CDH3ST, T01.CDAF31, T01.CDAF32, T03.ADACQT, T01.CDCQCD, " _ & "T01.CDANVA, T01.CDUUCA, " _ & "SUBSTR(T01.CDALDT,4,2)||'/'||SUBSTR(T01.CDALDT,6,2)||'/'||SUBSTR(INT(SUBSTR(T01.CDALDT,1,1))+19,1,2)||SUBSTR(T01.CDALDT,2,2), " _ & "T03.ADDRNB, " _ & "SUBSTR(T03.ADBJDT,4,2)||'/'||SUBSTR(T03.ADBJDT,6,2)||'/'||SUBSTR(INT(SUBSTR(T03.ADBJDT,1,1))+19,1,2)||SUBSTR(T03.ADBJDT,2,2), " _ & "SUBSTR(T03.ADAKDT,4,2)||'/'||SUBSTR(T03.ADAKDT,6,2)||'/'||SUBSTR(INT(SUBSTR(T03.ADAKDT,1,1))+19,1,2)||SUBSTR(T03.ADAKDT,2,2), " _ & "SUBSTR(T03.ADBIDT,4,2)||'/'||SUBSTR(T03.ADBIDT,6,2)||'/'||SUBSTR(INT(SUBSTR(T03.ADBIDT,1,1))+19,1,2)||SUBSTR(T03.ADBIDT,2,2), " _ & "T01.CDFCNB " _ & "FROM S10A7F0P.AMFLIBT.MBCDREP T01, S10A7F0P.AMFLIBT.MBBFREP T02, S10A7F0P.AMFLIBT.MBADREP T03, S10A7F0P.AMFLIBT.MBC6REP T04 " _ & "WHERE T01.CDAF31 <> 'ORDER COMPLETE' AND T01.CDAAYY=T02.CUSNO AND T01.CDDCCD=T03.ADDCCD AND T01.CDCVNB=T03.ADCVNB AND T01.CDDCCD=T04.C6DCCD AND " _ & "T01.CDCVNB=T04.C6CVNB AND T01.CDFCNB=T03.ADFCNB AND T01.CDCVNB='" & space_padded_order_num & "'" Set rs = CreateObject("ADODB.Recordset") Set rs.ActiveConnection = conn ' Open Results Set rs.Open Sql ' Check for ADO DB COnnection Errors If conn.Errors.Count > 0 Then For Each ADOErr In conn.Errors MsgBox ADOErr.Description Next End If ' Copy data in results set to Excel "Sheet2" Sheets("Sheet2").Range("A1").CopyFromRecordset rs Sheets("Sheet2").Activate ActiveSheet.Range("a1").Select 'How many rows are there? With ActiveSheet lastrow = .Range("B" & .Rows.Count).End(xlUp).Row End With Sub Fix_Buttons() 'FIX BUTTONS 'WHERE Click button_WHERE.AutoSize = False button_WHERE.Height = 25 button_WHERE.Width = 50 button_WHERE.Font.Size = 12 button_WHERE.Top = 89 button_WHERE.Left = 15 'COMP Click button_COMP.AutoSize = False button_COMP.Height = 25 button_COMP.Width = 50 button_COMP.Font.Size = 12 button_COMP.Top = 126 button_COMP.Left = 15 'CLR Click button_CLR.AutoSize = False button_CLR.Height = 25 button_CLR.Width = 50 button_CLR.Font.Size = 12 button_CLR.Top = 163 button_CLR.Left = 15 End Sub Private Sub button_CLR_Click() Application.ScreenUpdating = True Application.StatusBar = "" 'wipe out the WhereUsed ActiveWorkbook.Worksheets("WhereUsed").Columns("A:AA").ClearContents ' Sheets("ControlPanel").Range("D2").Value = "N10" ' Sheets("ControlPanel").Range("D3").Value = "N18" 'clean up the G column ' Sheets("ControlPanel").Range("G2:G5").ClearContents 'Fix Button alignment (if it gets messed up) Call Fix_Buttons End Sub Private Sub button_COMP_Click() Dim datsrc As String Dim uname As String Dim upass As String Dim lastrow As Long Dim qEndOfSQL As String Dim qSingle As String Dim qStarts As String Dim qList As String Dim qItem As String Dim qIstart As String Dim qContains As String Sheets("BOMCompLIB").Columns("A:P").ClearContents Sheets("BOMCompLIB").Range("A1").Value = "PARENT" Sheets("BOMCompLIB").Range("B1").Value = "CUSTPN" Sheets("BOMCompLIB").Range("C1").Value = "CHILD" Sheets("BOMCompLIB").Range("D1").Value = "QTYNEEDED" Sheets("BOMCompLIB").Range("E1").Value = "CMPCUSTPN" Sheets("BOMCompLIB").Range("F1").Value = "TOPDESC" Sheets("BOMCompLIB").Range("G1").Value = "COMPDESC" Sheets("BOMCompLIB").Range("H1").Value = "Reserved" EndOfSQL = "" datsrc = "CP00" uname = "CPYS" upass = "xxxxxx" Application.ScreenUpdating = False ' Execute query to iSeries system On Error Resume Next Set conn = CreateObject("ADODB.Connection") conn.Open "Provider=IBMDA400; Force Translate = 0;" & "Data Source=" & datsrc & ";" & "User ID=" & uname & ";" & "Password=" & upass & ";" Sql = "Select Distinct A0.PITMCU, B0.UU25AD, A0.CITMCU, A0.QPERCU, C0.UU25AD As UU25AD1, B0.ITDSAD As TOPDESC, " _ & "C0.ITDSAD As COMPDESC " _ & "From S10A7F0P.AMFLIB.PSTDTLL0 A0 Left Join " _ & "S10A7F0P.AMFLIB.ITMRVAL0 B0 On B0.ITNOAD = A0.PITMCU Left Join " _ & "S10A7F0P.AMFLIB.ITMRVAL1 C0 On C0.ITNOAD = A0.CITMCU " Set rs = CreateObject("ADODB.Recordset") Set rs.ActiveConnection = conn ' Open Results Set rs.Open Sql ' Check for ADO DB COnnection Errors If conn.Errors.Count > 0 Then For Each ADOErr In conn.Errors MsgBox ADOErr.Description Next End If ' Copy data in results set to Excel ActiveWorkbook.Worksheets("BOMCompLIB").Range("A2").CopyFromRecordset rs ActiveSheet.Range("A2").Select ' Close DB Connection Set conn = Nothing Set rs = Nothing End Sub 'ADVANCED FILTER CODE ***These lines have to stay together****************** '************************because the output landing moves******************* Set rgData = ThisWorkbook.Worksheets("BOMCompLIB").Range("A1").CurrentRegion Set rgCriteria = ThisWorkbook.Worksheets("AFTemplate").Range("B1:I2") Set rgOutput = ThisWorkbook.Worksheets("AFTemplate").Range("B5") rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput With Sheets("AFTemplate") bottomAFRESULTSrow = .Range("B" & .Rows.Count).End(xlUp).Row End With If bottomAFRESULTSrow = 5 Then 'there was no BOM Parent found Sheets("AFTemplate").Range("B6").Value = "END-ITEM" bottomAFRESULTSrow = 6 End If topAFRESULTSrow = 6 Sheets("AFTemplate").Range("B" & topAFRESULTSrow & ":B" & bottomAFRESULTSrow).Copy Destination:=ActiveSheet.Range("C" & thisrow) Sheets("AFTemplate").Range("E" & topAFRESULTSrow & ":E" & bottomAFRESULTSrow).Copy Destination:=ActiveSheet.Range("B" & thisrow) With ActiveSheet lastrow = .Range("C" & .Rows.Count).End(xlUp).Row End With If lastrow > thisrow Then ActiveSheet.Range("A" & thisrow).Copy Destination:=ActiveSheet.Range("A" & thisrow + 1 & ":A" & lastrow) End If 'clear the AF Template for the next run Sheets("AFTemplate").Range("A2:K2000").ClearContents 'next part request from ControlPanel thisREQUESTrow = thisREQUESTrow + 1 thispart = Sheets("ControlPanel").Range("E" & thisREQUESTrow).Value thisrow = lastrow + 1 ActiveSheet.Range("A" & thisrow).Value = thispart Sheets("AFTemplate").Range("D2").Value = thispart thiscount = thiscount + 1 Loop 'Sort the results to ready the next level ActiveWorkbook.Worksheets("WhereUsed").Sort.SortFields.Clear ActiveWorkbook.Worksheets("WhereUsed").Sort.SortFields.Add Key:=Range( _ "C2:C" & lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With ActiveWorkbook.Worksheets("WhereUsed").Sort .SetRange Range("A2:C" & lastrow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With x = 1 'LEVEL2 ***************************************************************************************************** LEVEL2 ActiveSheet.Range("E1").Value = "2 Levels Up" ActiveSheet.Range("D1").Value = "QTYForOne" thiscount = 1 thisrow = 2 totallevel = lastrow Do While thisrow <= lastrow Application.ScreenUpdating = True Application.StatusBar = "Pass 2:" & thiscount & " of " & totallevel - 1 Application.ScreenUpdating = False 'begin processing thispart = ActiveSheet.Range("C" & thisrow).Value Sheets("AFTemplate").Range("D2").Value = thispart 'ADVANCED FILTER CODE ***These lines have to stay together****************** '************************because the output landing moves******************* Set rgData = ThisWorkbook.Worksheets("BOMCompLIB").Range("A1").CurrentRegion Set rgCriteria = ThisWorkbook.Worksheets("AFTemplate").Range("B1:I2") Set rgOutput = ThisWorkbook.Worksheets("AFTemplate").Range("B5") rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput With Sheets("AFTemplate") bottomAFRESULTSrow = .Range("B" & .Rows.Count).End(xlUp).Row End With If bottomAFRESULTSrow = 5 Then 'there was no BOM Parent found 'Sheets("AFTemplate").Range("B6").Value = "FG ITEM" bottomAFRESULTSrow = 6 End If topAFRESULTSrow = 6 'insert rows on WhereUsed if needed morerows = False If bottomAFRESULTSrow > topAFRESULTSrow Then rowinserts = bottomAFRESULTSrow - topAFRESULTSrow ActiveSheet.Range("B" & thisrow + 1 & ":B" & thisrow + rowinserts).EntireRow.Insert ActiveSheet.Range("A" & thisrow & ":C" & thisrow).Copy Destination:=ActiveSheet.Range("A" & thisrow + 1 & ":C" & thisrow + rowinserts) morerows = True End If 'copy the AF results Sheets("AFTemplate").Range("B" & topAFRESULTSrow & ":B" & bottomAFRESULTSrow).Copy Destination:=ActiveSheet.Range("E" & thisrow) Sheets("AFTemplate").Range("E" & topAFRESULTSrow & ":E" & bottomAFRESULTSrow).Copy Destination:=ActiveSheet.Range("D" & thisrow) With ActiveSheet lastrow = .Range("C" & .Rows.Count).End(xlUp).Row End With 'Compute the next thisrow when rows are inserted If morerows Then thisrow = thisrow + rowinserts + 1 Else thisrow = thisrow + 1 End If 'clear the AF Template for the next run Sheets("AFTemplate").Range("A2:K2000").ClearContents 'next part request from ControlPanel thispart = ActiveSheet.Range("C" & thisrow).Value Sheets("AFTemplate").Range("D2").Value = thispart thiscount = thiscount + 1 Loop 'Sort the results to ready the next level ActiveWorkbook.Worksheets("WhereUsed").Sort.SortFields.Clear ActiveWorkbook.Worksheets("WhereUsed").Sort.SortFields.Add Key:=Range( _ "E2:E" & lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With ActiveWorkbook.Worksheets("WhereUsed").Sort .SetRange Range("A2:E" & lastrow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'what is the lastrow after the sort? With ActiveSheet lastrow = .Range("E" & .Rows.Count).End(xlUp).Row End With x = 1 ActiveSheet.Columns("A:A").Select Selection.ColumnWidth = 10.14 ActiveSheet.Columns("B:Y").Select Selection.ClearContents Selection.ColumnWidth = 6.14 Call BuildPivotData MS-SQL Server Connect SQL SERVER SQL SERVER 'Setup for query On Error Resume Next Set conn = CreateObject("ADODB.Connection") conn.Open "provider=SQLOLEDB.1;data source=CPI-SQL;initial catalog=NCRPhase2Web;User ID=NCRManagement;Password=xxxxxxxx;" Set rs = CreateObject("ADODB.Recordset") Set rs.ActiveConnection = conn 'Open Results Set rs.Open Sql 'Check for ADO DB Connection Errors If conn.Errors.Count > 0 Then For Each ADOErr In conn.Errors MsgBox ADOErr.Description, vbCritical, "NCR Data" Next 'Exit Sub End If ' Check we have data. If Not rs.EOF Then ' Transfer result. Sheets("NCR Data").Range("A2").CopyFromRecordset rs ' Close the recordset rs.Close Else MsgBox "Error: No records returned.", vbCritical End If 'Headings & columns With Sheets("NCR Data") .Range("A1").Value = "NCRNum" .Range("B1").Value = "LineNum" .Range("C1").Value = "AddDate_NCR" .Range("D1").Value = "PO_MO" .Range("E1").Value = "VendorName" .Range("F1").Value = "VendorNum" .Range("G1").Value = "PartNum" .Range("H1").Value = "PartName" .Range("I1").Value = "ItemClass" .Range("J1").Value = "Qty" .Range("K1").Value = "CPIWarehouse" .Range("L1").Value = "InitialResp" .Range("AG2").FormulaR1C1 = "=IF(RC[-11]=0,RC[-10],RC[-11])" .Columns("aG:aG").NumberFormat = "m/d/yyyy" .Range("AH1").Value = "Duplicate" .Range("AH2").FormulaR1C1 = "=COUNTIF(R2C1:RC[-33],RC[-33])" .Columns("Z:Z").NumberFormat = "General" .Range("AI1").Value = "Overage" .Range("AI2").FormulaR1C1 = "=IF(RC[-11]<>""CLOSED"","""",RC[-17]-RC[-15])" .Columns("AI:AI").NumberFormat = "General" .Range("AJ1").Value = "Defect Detail" .Range("AJ2").FormulaR1C1 = "=CONCATENATE(RC[-20],"" "", RC[-19])" .Range("AK1").Value = "QE" .Range("AL1").Value = "Development" .Range("AM1").Value = "Internal/External" CONVERT DATA GRID TO table Sheets("NCR Data").Columns("A:AN").EntireColumn.AutoFit Sheets("NCR Data").Unprotect 

'convert Range to Table by setting range (rng):
Set rng = Sheets("NCR Data").Range("A1:AN" & lastrow) 
With Sheets("NCR Data") 
    .ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "NCR_Raw_Data" 
End With 

Fill zero and format large grid using floating right column:
lastcol = Sheets("ExpReceiptsPIV").Cells(1, Columns.Count).END(xlToLeft).Column 
With Sheets("ExpReceiptsPIV") 
    lastrow = .Range("A" & .Rows.Count).END(xlUp).Row 
End With 
With ThisWorkbook.Sheets("ExpReceiptsPIV") 
    Set RngTarget = .Range(.Cells(2, 2), .Cells(lastrow, lastcol)) 
End With 
RngTarget.SpecialCells(xlCellTypeBlanks) = 0 
RngTarget.NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" 
With ThisWorkbook.Sheets("ExpReceiptsPIV") 
    Set RngTarget = .Range(.Cells(1, 1), .Cells(lastrow, lastcol)) 
End With 
RngTarget.Columns.AutoFit 

RANDOM ELEMENTS 'range of subject words lowerbound = 2 With Sheets("DataLib") upperbound = .Range("A" & .Rows.Count).End(xlUp).Row End With 'cellrange of random numbers Set cellRange = Range("F2:F" & qtymeetings + 1) cellRange.Clear firstRand = 0 secondRand = 0 For Each Rng In cellRange firstRand = Int((upperbound - lowerbound + 1) * Rnd + lowerbound) secondRand = Int((upperbound - lowerbound + 1) * Rnd + lowerbound) Do While firstRand = secondRand secondRand = Int((upperbound - lowerbound + 1) * Rnd + lowerbound) Loop thisMtgSubject = Sheets("DataLib").Range("A" & firstRand).Value & " " & Sheets("DataLib").Range("A" & secondRand).Value Rng.Value = thisMtgSubject Next Sheets("Dashboard").Range("G1").EntireColumn.ClearContents 'no borders on white With Sheets("Dashboard").Range("F1:G30").Interior .PatternTintAndShade = 0 End With Sheets("Dashboard").Range("F1").EntireColumn.AutoFit INSERTING MEETINGS INTO OUTLOOK Sub SUBMIT_Button_Click() Set MyOutlook = CreateObject("Outlook.Application") thisrow = 2 With Sheets("Dashboard") lastrow = .Range("G" & .Rows.Count).End(xlUp).Row End With Do While thisrow <= lastrow thisSubject = Sheets("Dashboard").Range("F" & thisrow).Value thisMeetTime = Sheets("Dashboard").Range("G" & thisrow).Value thisRoom = Sheets("Dashboard").Range("H" & thisrow).Value Set MyMeeting = MyOutlook.CreateItem(1) With MyMeeting '.display .Subject = thisSubject & Path .Location = thisRoom .Duration = 60 .Start = thisMeetTime .Save 'Real meetings ' .to = thisEmail ' .CC = "" ' .BCC = "" ' .HTMLBody = strBody & .HTMLBody ' .Attachments.Add ("C:SurveyRMI_CMRT_6.22.xlsx") ' .Send End With thisrow = thisrow + 1 Loop End Sub Number formats With ThisWorkbook.Sheets("FINAL") Set RngTarget = .Range(.Cells(2, 3), .Cells(lastrow, lastcol)) End With Sheets("FINAL").Range("B1").Value = "Data" Sheets("FINAL").Range("B:B").HorizontalAlignment = xlLeft RngTarget.SpecialCells(xlCellTypeBlanks) = 0 RngTarget.NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" Front and Back date math: Application.ScreenUpdating = True Application.StatusBar = "Column History Adjustments... Part 8 of 10" Application.ScreenUpdating = False 'Analyze date range on ControlPanel - insert columns if necessary - define year-mo headings - move & remove the Past Due column frontyear = Year(Sheets("ControlPanel").Range("D2").Value) frontmonth = Month(Sheets("ControlPanel").Range("D2").Value) backyear = Year(Sheets("ControlPanel").Range("E2").Value) backmonth = Month(Sheets("ControlPanel").Range("E2").Value) frontdate = frontmonth & "/28/" & frontyear backdate = backmonth & "/28/" & backyear monthsneeded = Int((DateValue(backdate) - DateValue(frontdate)) / 30) + 1 'setup going into loop 'We will be looping and increasing the year-month code thiscolumncount = 1 Do While thiscolumncount <= monthsneeded thismonthcode = frontyear & " " & MonthName(frontmonth, True) With ThisWorkbook.Sheets("FINAL") Set RngTarget = .Cells(1, thiscolumncount + 3) End With If RngTarget.Value <> thismonthcode Then RngTarget.EntireColumn.Insert With ThisWorkbook.Sheets("FINAL") Set RngTargetBefore = .Cells(1, thiscolumncount + 3) RngTargetBefore.Value = thismonthcode End With End If 'next month date code frontdate = DateValue(frontdate) + 30 frontyear = Year(frontdate) frontmonth = Month(frontdate) thiscolumncount = thiscolumncount + 1 Loop RC Cell references with ranges: With ThisWorkbook.Sheets("FINAL") Set RngSource = .Range(.Cells(2, 3), .Cells(lastrow, 3)) End With 'with the source range set, now go find this month's column thiscol = 4 Do While thiscol <= 22 'just any random column out to the right 'first, check the column heading for match With ThisWorkbook.Sheets("FINAL") Set RngSourceHeader = .Cells(1, thiscol) End With If RngSourceHeader = thismonthcode Then thiscol = thiscol - 1 Exit Do Else thiscol = thiscol + 1 End If Loop 'now copy the Past Due to the target column With ThisWorkbook.Sheets("FINAL") Set RngTarget = .Cells(2, thiscol) End With RngSource.Copy RngTarget With ThisWorkbook.Sheets("FINAL") Set RngSourceHeader = .Cells(1, thiscol) End With RngSourceHeader.Value = RngSourceHeader.Value & " (PsDue)" 'now copy the Past Due to the target column 'wait.... let's use this column before delete Sheets("FINAL").Range("C:C").EntireColumn.Delete 'set a row numbering to resort Sheets("FINAL").Range("C2").Value = 1 thisformula = "=C2+1" Sheets("FINAL").Range("C3").Formula = thisformula Sheets("FINAL").Range("C3").Copy Sheets("FINAL").Range("C4:C" & lastrow) Sheets("FINAL").Range("C2:C" & lastrow).Copy With Sheets("FINAL") .Range("C2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End With Application.CutCopyMode = False 'sort inventory rows up top Sheets("FINAL").Sort.SortFields.Clear Sheets("FINAL").Sort.SortFields.Add Key:=Range("B2:B" & lastrow) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Sheets("FINAL").Sort .SetRange Range("A2:AC" & lastrow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Colors and such: 'Color the PM Sales rows light blue With ThisWorkbook.Sheets("FINAL") Set RngTarget = .Range(.Cells(2, 2), .Cells(topRcptsrow - 1, lastcol)) End With With RngTarget.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 .TintAndShade = 0.599993896298105 .PatternTintAndShade = 0 End With 'Color the Receipt rows light orange With ThisWorkbook.Sheets("FINAL") Set RngTarget = .Range(.Cells(topRcptsrow, 2), .Cells(lastrow, lastcol)) End With With RngTarget.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With 'find the row that the Receipts start in WhatImLookingFor = "PM Sales" With Sheets("FINAL").Range("B:B") Set FndRng = .Find(What:=WhatImLookingFor, LookIn:=xlValues, LookAt:=xlWhole) If Not FndRng Is Nothing Then ' <-- Find was successful topSalesrow = FndRng.Row - 1 End If End With 'Color the Inventory/Delta rows light orange-red With ThisWorkbook.Sheets("FINAL") Set RngTarget = .Range(.Cells(2, 2), .Cells(topSalesrow, lastcol)) End With With RngTarget.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 10066431 .TintAndShade = 0 .PatternTintAndShade = 0 End With 'Border the whole thing with a navy blue border With ThisWorkbook.Sheets("FINAL") Set RngTarget = .Range(.Cells(2, 2), .Cells(lastrow, lastcol)) End With RngTarget.Borders(xlDiagonalDown).LineStyle = xlNone RngTarget.Borders(xlDiagonalUp).LineStyle = xlNone With RngTarget.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ThemeColor = 9 .TintAndShade = -0.249946592608417 .Weight = xlThin End With With RngTarget.Borders(xlEdgeTop) .LineStyle = xlContinuous .ThemeColor = 9 .TintAndShade = -0.249946592608417 .Weight = xlThin End With With RngTarget.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 9 .TintAndShade = -0.249946592608417 .Weight = xlThin End With With RngTarget.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 9 .TintAndShade = -0.249946592608417 .Weight = xlThin End With With RngTarget.Borders(xlInsideVertical) .LineStyle = xlContinuous .ThemeColor = 9 .TintAndShade = -0.249946592608417 .Weight = xlThin End With With RngTarget.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ThemeColor = 9 .TintAndShade = -0.249946592608417 .Weight = xlThin End With Numbers left right center Sheets("ExpReceipts").Range("A:A").HorizontalAlignment = xlLeft Sheets("ExpReceipts").Range("B:B").HorizontalAlignment = xlCenter Sheets("ExpReceipts").Range("C:Z").HorizontalAlignment = xlRight Sheets("ExpReceipts").Range("C2:Z" & lastrow).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" MACRO GENERATOR MACRO GENERATOR MACRO GENERATOR MACRO GENERATOR MACRO GENERATOR MACRO GENERATOR MACRO GENERATOR MACRO GENERATOR MACRO GENERATOR Module1: Sub ValuePaster() 'PASTE VALUES ROUTINE (the Control+Shift+N Macro) thisrow = ActiveCell.Row thiscolumn = ActiveCell.Column ActiveSheet.Columns(thiscolumn + 1).Select Selection.Insert Shift:=xlToRight ActiveSheet.Cells(thisrow, thiscolumn).Select ActiveSheet.Range(Selection, Selection.End(xlDown)).Select Selection.Copy ActiveCell.Offset(ColumnOffset:=1).Activate Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Selection.Copy ActiveCell.Offset(ColumnOffset:=-1).Activate ActiveSheet.Paste Application.CutCopyMode = False ActiveSheet.Columns(thiscolumn + 1).Select Selection.Delete ActiveSheet.Cells(thisrow, thiscolumn).Select End Sub Sub QuotesAndCommas() 'CONCATENATE FOR SQL IN() Clause (the Control+Shift+H Macro) DOES NOT WORK AFTER COLUMN Z thisrow = ActiveCell.Row thiscolumn = ActiveCell.Column ActiveSheet.Range(Chr(64 + thiscolumn) & "10000").Select Selection.End(xlUp).Select lastrow = ActiveCell.Row ActiveSheet.Range(Chr(65 + thiscolumn) & thisrow).Select 'thisformula = "=CONCATENATE(""'""," & thiscolumn & thisrow & ",""',"")" ActiveCell.Formula = "=CONCATENATE(""'""," & Chr(64 + thiscolumn) & thisrow & ",""',"")" ActiveSheet.Range(Chr(65 + thiscolumn) & thisrow).Copy Destination:=ActiveSheet.Range(Chr(65 + thiscolumn) & thisrow + 1 & ":" & Chr(65 + thiscolumn) & lastrow) ActiveSheet.Range(Chr(64 + thiscolumn) & thisrow).Select End Sub Sub CopyThatDown() 'COPY DOWN VALUE to WHOLE COLUMN MARKING BOTTOM OF COLUMN (the Ctrl+Shift+K Macro) thisrow = ActiveCell.Row thiscolumn = ActiveCell.Column ActiveSheet.Range(Selection, Selection.End(xlDown)).Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Cells(thisrow, thiscolumn).Select End Sub Sub DollarsAndCents() 'SET NUMBER FORMATS TO 0.00 (the Ctrl+Shift+J Macro) ActiveSheet.Range(Selection, Selection.End(xlDown)).Select Selection.NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" ActiveCell.Offset(ColumnOffset:=1).Activate ActiveCell.Offset(ColumnOffset:=-1).Activate End Sub Sub VlookerSort() 'SORT a range defined by the top row select. Used after VLOOKUP to sort #N/A's to the bottom (the Ctrl+Shift+M Macro) 'nFirstRow = r.Row 'nLastColumn = r.Columns.Count + r.Column - 1 Dim r As Range thisrow = ActiveCell.Row thiscolumn = ActiveCell.Column ActiveSheet.Cells(thisrow, thiscolumn).CurrentRegion.Select Set r = Selection nFirstRow = thisrow nFirstColumn = r.Column nLastRow = r.Rows.Count + r.Row - 1 nLastColumn = thiscolumn ActiveSheet.Sort.SortFields.Clear ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(nFirstRow, nLastColumn), Cells(nLastRow, nLastColumn)) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveSheet.Sort .SetRange Range(Cells(nFirstRow, nFirstColumn), Cells(nLastRow, nLastColumn)) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ActiveSheet.Cells(thisrow, thiscolumn).Select x = thisrow Do While x <= nLastRow ActiveCell.Offset(RowOffset:=1).Activate If Trim(ActiveCell.Text) = "#N/A" Then Exit Do End If x = x + 1 Loop End Sub Sub HighlightRow() 'YELLOW HIGHLIGHT determine the row range, then set the cell backgrounds yellow (the Ctrl+Shift+Y Macro) 'nFirstRow = r.Row 'nLastColumn = r.Columns.Count + r.Column - 1 Dim r As Range thisrow = ActiveCell.Row thiscolumn = ActiveCell.Column If ActiveCell.Interior.ColorIndex = 6 Then ThisRowIsYellow = True End If ActiveSheet.Cells(thisrow, thiscolumn).CurrentRegion.Select Set r = Selection nFirstRow = thisrow nFirstColumn = r.Column nLastRow = r.Rows.Count + r.Row - 1 nLastColumn = r.Columns.Count + r.Column - 1 'Select ActiveSheet.Range(Cells(thisrow, nFirstColumn), Cells(thisrow, nLastColumn)).Select 'color rows If ThisRowIsYellow Then 'Set back to no yellow With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone Else 'Set cell backgrounds to yellow With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.249946592608417 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.249946592608417 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.249946592608417 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.249946592608417 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.249946592608417 .Weight = xlThin End With Selection.Borders(xlInsideHorizontal).LineStyle = xlNone End If ActiveSheet.Cells(thisrow, thiscolumn).Select End Sub Sub CreateShortcut() Application.OnKey "+^{N}", "ValuePaster" Application.OnKey "+^{H}", "QuotesAndCommas" Application.OnKey "+^{J}", "DollarsAndCents" Application.OnKey "+^{K}", "CopyThatDown" Application.OnKey "+^{M}", "VLookerSort" Application.OnKey "+^{Y}", "HighlightRow" End Sub ThisWorkbook: Private Sub Workbook_Open() Call Module1.CreateShortcut End Sub  

Search