Through some assistance here and through google, I have copy/pasted a frankenstien of some code together that does exactly what I need. My question tho, is if there is any ways of cleaning this up, or am I using any bad practices/principles that could/should be changed?
Thanks in advance to all!
Thanks in advance to all!
Code:
Function Test()
Dim wb As Excel.Workbook, xlApp As Excel.Application
Dim rng As Object, ws As Object, y As Long
Dim LastRow As Long, lColumn As Long, x As Long, LastColumn As Long
Dim headerColumn As String, headerColumnTwo As String, strValue As String
Dim pivotWS As Excel.Worksheet, dataWS As Excel.Worksheet
Dim PCache As Excel.PivotCache, PTable As Excel.PivotTable
Dim PRange As Excel.Range
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set wb = xlApp.Workbooks.Open("C:\Test\Excel\Test.xlsx", False, False)
Set ws = wb.Sheets(1)
ws.Rows("1:2").Delete Shift:=xlUp
ws.Rows("2:6").Delete Shift:=xlUp
ws.Rows("2:2").Delete Shift:=xlUp
wb.Sheets(1).Columns("B:H").EntireColumn.Delete
ws.Range("A1").Value = "empID"
wb.Save
LastRow = ws.Range("A" & ws.Rows.Count).End(-4162).Row
lColumn = ws.Range("XFD1").End(-4159).Column
For y = 2 To LastRow
strValue = ""
For x = 2 To lColumn
strValue = strValue & "." & ws.Cells(y, x)
Next x
strValue = Right(strValue, Len(strValue) - 1)
ws.Cells(y, lColumn + 1).Value = strValue
Next y
headerColumn = Number2Letter(lColumn + 1)
Range(headerColumn & "1").Value = "KitID"
wb.Save
CreateKitNames
headerColumnTwo = Number2Letter(lColumn + 2)
Range(headerColumnTwo & "1").Value = "empNames"
wb.Save
ws.Columns("H:I").Copy
Set ws2 = wb.Sheets.Add(After:=wb.Worksheets("QRS"))
ws2.Name = "Data"
ws2.Paste
xlApp.CutCopyMode = False
ws2.Range("$A$1:$B$" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
ws2.Sort.SortFields.Clear
ws2.Sort.SortFields.Add2 Key:=Range("A2:A" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws2.Sort
.SetRange Range("A1:B" & LastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
xlApp.Goto ws2.Range("A1"), True
ws2.Columns("A:A").EntireColumn.AutoFit
wb.Save
wb.Sheets.Add(Before:=Excel.ActiveSheet).Name = "PivotTable"
Set pivotWS = wb.Worksheets("PivotTable")
Set dataWS = wb.Worksheets("QRS")
LastColumn = dataWS.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = dataWS.Cells(1, 1).Resize(LastRow, LastColumn)
Set PCache = Excel.ActiveWorkbook.PivotCaches.Create(SourceType:=Excel.xlDatabase, SourceData:=PRange)
Set PTable = PCache.CreatePivotTable(TableDestination:=pivotWS.Cells(3, 1), TableName:="TestPivotTable")
With PTable.PivotCache
.RefreshOnFileOpen = False
.MissingItemsLimit = Excel.xlMissingItemsDefault
End With
PTable.RepeatAllLabels xlRepeatLabels
wb.Save
With PTable.PivotFields("empNames")
.Orientation = Excel.xlRowField
.Position = 1
End With
With PTable.PivotFields("empID")
.Orientation = Excel.xlDataField
.Caption = "Count of empID"
.Function = Excel.xlCount
End With
wb.Save
wb.Close
xlApp.DisplayAlerts = False
xlApp.Quit
End Function
Private Function Number2Letter(ColumnNumber As Integer)
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim ColumnLetter As String
ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
Number2Letter = ColumnLetter
End Function
Function CreateNames()
Dim dataColumn As Long
Dim dataVal As String, letterVal As String, decodedVal As String
dataColumn = Excel.Cells(1, Excel.Columns.Count).End(Excel.xlToLeft).Column
outputColumn = dataColumn + 1
tempCol1 = dataColumn + 2
tempCol2 = dataColumn + 3
Excel.Columns(dataColumn).Copy Excel.Columns(tempCol1)
Excel.Cells(1, tempCol1).Delete
Excel.Columns(tempCol1).RemoveDuplicates Columns:=Array(1)
Excel.Columns(tempCol1).Sort Key1:=Excel.Columns(tempCol1), Order1:=xlAscending, Header:=xlN
For i = 1 To Excel.Cells(1, tempCol1).End(Excel.xlDown).Row
letterVal = Split(Cells(1, i).Address, "$")(1)
Cells(i, tempCol2).Value = letterVal
Next i
For i = 2 To Excel.Cells(1, dataColumn).End(Excel.xlDown).Row
decodedVal = Excel.WorksheetFunction.VLookup(Excel.Cells(i, dataColumn).Value, Excel.Range(Cells(1, tempCol1), Cells(Excel.Cells(1, tempCol1).End(Excel.xlDown).Row, tempCol2)), 2)
Cells(i, outputColumn) = decodedVal
Next i
Excel.Columns(tempCol1).Delete
Excel.Columns(tempCol1).Delete
Excel.Columns(outputColumn).Select
End Function