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