Sub processData()
Application.ScreenUpdating = False
Application.EnableEvents = False
'declaration of variables
Dim wb As Workbook, wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim sfile1 As String, sfile2 As String
Dim uniqueCol As Integer
Dim i As Integer
Dim lr1 As Long, lr2 As Long
Dim rawNameArr1 As Variant, rawNameArr2 As Variant
Dim uniNameArr() As Variant
Dim cleanName As String
Dim uniPos As Integer
Dim newlr As Long
Dim rawClientArr1 As Variant, rawClientArr2 As Variant
Dim t1c1 As Variant, t1c2 As Variant, t2c1 As Variant, t2c2 As Variant
Dim j As Long
Dim tempArr() As Variant
Dim tempPos As Byte
Dim repCount As Byte
Dim showC As String, showE As String, showK As String, showM As String
Dim showCArr As Variant, showEArr As Variant, showKArr As Variant, showMArr As Variant
Dim myMsg As Byte
myMsg = MsgBox(Prompt:="Do you want to continue?", Title:="Run Macro", Buttons:=vbYesNo)
If myMsg <> 6 Then Exit Sub
Set wb = ThisWorkbook
stemp.Visible = xlSheetVisible
sfile1 = getFileName(sctrl.Range("file1").Value)
sfile2 = getFileName(sctrl.Range("file2").Value)
'check if filename already exists
If ifSheetExists(sfile1) Or ifSheetExists(sfile2) Then
MsgBox Prompt:="Filename already found as sheet in this workbook." & vbNewLine & vbNewLine _
& "Rename the files to be pulled.", Title:="Duplicate Sheet"
Exit Sub
End If
sfile1 = sctrl.Range("file1").Value
sfile2 = sctrl.Range("file2").Value
'duplicate template sheet
stemp.Copy After:=wb.Sheets(wb.Sheets.Count)
Set ws = wb.Sheets(wb.Sheets.Count)
ws.Name = "PLELIM CHART" & countPlelimSheets
'open workbook1 and transfer data
Set wb1 = Workbooks.Open(Filename:=sfile1)
wb1.Sheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
Set ws1 = wb.Sheets(wb.Sheets.Count)
ws1.Name = getFileName(sfile1)
wb1.Close SaveChanges:=False
'open workbook2 and transfer data
Set wb2 = Workbooks.Open(Filename:=sfile2)
wb2.Sheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
Set ws2 = wb.Sheets(wb.Sheets.Count)
ws2.Name = getFileName(sfile2)
wb2.Close SaveChanges:=False
'label file names into column P of new PLELIM sheet
ws.Range("tfile1").Value = ws1.Name
ws.Range("tfile2").Value = ws2.Name
uniqueCol = ws.Range("tfile1").Offset(0, 2).Column
lr1 = ws1.Range("C" & Rows.Count).End(xlUp).Row
lr2 = ws2.Range("C" & Rows.Count).End(xlUp).Row
'get unique names for sheet1
rawNameArr1 = Application.Transpose(ws1.Range("C2:C" & lr1).Value)
'clean sales rep name (remove after semi-colon)
For i = LBound(rawNameArr1) To UBound(rawNameArr1)
If InStr(1, rawNameArr1(i), ";") > 0 Then
rawNameArr1(i) = Left(rawNameArr1(i), InStr(1, rawNameArr1(i), ";") - 1)
ElseIf InStr(1, rawNameArr1(i), "&") > 0 Then
rawNameArr1(i) = Left(rawNameArr1(i), InStr(1, rawNameArr1(i), "&") - 2)
End If
Next i
For i = LBound(rawNameArr1) To UBound(rawNameArr1)
If InStr(1, rawNameArr1(i), ";") > 0 Then
cleanName = Left(rawNameArr1(i), InStr(1, rawNameArr1(i), ";") - 1)
ElseIf InStr(1, rawNameArr1(i), "&") > 0 Then
cleanName = Left(rawNameArr1(i), InStr(1, rawNameArr1(i), "&") - 2)
Else
cleanName = rawNameArr1(i)
End If
If i = 1 Then
ReDim Preserve uniNameArr(0)
uniNameArr(0) = cleanName
uniPos = 1
Else
If Not IsInArray(rawNameArr1(i), uniNameArr) Then
ReDim Preserve uniNameArr(uniPos)
uniNameArr(uniPos) = cleanName
uniPos = uniPos + 1
End If
End If
Next i
'get unique names for sheet2
rawNameArr2 = Application.Transpose(ws2.Range("C2:C" & lr2).Value)
'clean sales rep name (remove after semi-colon)
For i = LBound(rawNameArr2) To UBound(rawNameArr2)
If InStr(1, rawNameArr2(i), ";") > 0 Then
rawNameArr2(i) = Left(rawNameArr2(i), InStr(1, rawNameArr2(i), ";") - 1)
ElseIf InStr(1, rawNameArr2(i), "&") > 0 Then
rawNameArr2(i) = Left(rawNameArr2(i), InStr(1, rawNameArr2(i), "&") - 2)
End If
Next i
For i = LBound(rawNameArr2) To UBound(rawNameArr2)
If InStr(1, rawNameArr2(i), ";") > 0 Then
cleanName = Left(rawNameArr2(i), InStr(1, rawNameArr2(i), ";") - 1)
ElseIf InStr(1, rawNameArr2(i), "&") > 0 Then
cleanName = Left(rawNameArr2(i), InStr(1, rawNameArr2(i), "&") - 2)
Else
cleanName = rawNameArr2(i)
End If
If Not IsInArray(rawNameArr2(i), uniNameArr) Then
ReDim Preserve uniNameArr(uniPos)
uniNameArr(uniPos) = cleanName
uniPos = uniPos + 1
End If
Next i
'resize arrays
ReDim t1c1(UBound(uniNameArr))
ReDim t1c2(UBound(uniNameArr))
ReDim t2c1(UBound(uniNameArr))
ReDim t2c2(UBound(uniNameArr))
ReDim showCArr(UBound(uniNameArr))
ReDim showEArr(UBound(uniNameArr))
ReDim showKArr(UBound(uniNameArr))
ReDim showMArr(UBound(uniNameArr))
'store client names for table
rawClientArr1 = Application.Transpose(ws1.Range("A2:A" & lr1).Value)
rawClientArr2 = Application.Transpose(ws2.Range("A2:A" & lr2).Value)
'count each value per requirement for table1
For i = LBound(uniNameArr) To UBound(uniNameArr)
'file1
repCount = 0
ReDim tempArr(0)
showC = ""
showE = ""
showK = ""
showM = ""
For j = LBound(rawNameArr1) To UBound(rawNameArr1)
If uniNameArr(i) = rawNameArr1(j) Then
repCount = repCount + 1
showE = showE & "C" & j + 1 & ","
If tempArr(0) = "" Then
tempArr(0) = rawClientArr1(j)
tempPos = 1
showC = showC & "A" & j + 1 & ","
Else
If Not IsInArray(rawClientArr1(j), tempArr) Then
ReDim Preserve tempArr(tempPos)
tempArr(tempPos) = rawClientArr1(j)
tempPos = tempPos + 1
showC = showC & "A" & j + 1 & ","
End If
End If
End If
Next j
'store count in array
If repCount > 0 Then t1c2(i) = repCount
If tempArr(0) <> "" Then t1c1(i) = UBound(tempArr) + 1
If showE <> "" Then showEArr(i) = Left(showE, Len(showE) - 1)
If showC <> "" Then showCArr(i) = Left(showC, Len(showC) - 1)
'file2
repCount = 0
ReDim tempArr(0)
For j = LBound(rawNameArr2) To UBound(rawNameArr2)
If uniNameArr(i) = rawNameArr2(j) Then
repCount = repCount + 1
showM = showM & "C" & j + 1 & ","
If tempArr(0) = "" Then
tempArr(0) = rawClientArr2(j)
tempPos = 1
showK = showK & "A" & j + 1 & ","
Else
If Not IsInArray(rawClientArr2(j), tempArr) Then
ReDim Preserve tempArr(tempPos)
tempArr(tempPos) = rawClientArr2(j)
tempPos = tempPos + 1
showK = showK & "A" & j + 1 & ","
End If
End If
End If
Next j
If repCount > 0 Then t2c2(i) = repCount
If tempArr(0) <> "" Then t2c1(i) = UBound(tempArr) + 1
If showM <> "" Then showMArr(i) = Left(showM, Len(showM) - 1)
If showK <> "" Then showKArr(i) = Left(showK, Len(showK) - 1)
Next i
'Place values into table
ws.Range("A3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(uniNameArr)
ws.Range("I3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(uniNameArr)
newlr = ws.Range("A3000").End(xlUp).Row
ws.Range("A" & newlr + 1 & ":A2999").EntireRow.Delete
ws.Range("B3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(t1c1)
ws.Range("D3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(t1c2)
ws.Range("J3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(t2c1)
ws.Range("L3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(t2c2)
ws.Range("F3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(showCArr)
ws.Range("G3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(showEArr)
ws.Range("N3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(showKArr)
ws.Range("O3").Resize(UBound(uniNameArr) + 1, 1) = Application.Transpose(showMArr)
ws.Range("A3:G" & newlr).Sort key1:=ws.Range("A3"), order1:=xlAscending, Header:=xlNo
ws.Range("I3:O" & newlr).Sort key1:=ws.Range("I3"), order1:=xlAscending, Header:=xlNo
stemp.Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
MsgBox Prompt:="Macro Complete", Title:="Done"
ws.Activate
Application.EnableEvents = True
End Sub
Sub getFile1() 'macro to get full name of File 1
Dim mystr As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Title = "Select File 1"
If .Show = -1 Then
mystr = .SelectedItems.Item(1)
Else
MsgBox Prompt:="Cancelled", Title:="Selection Cancelled"
Exit Sub
End If
End With
sctrl.Range("file1").Value = mystr
End Sub
Sub getFile2() 'macro to get full name of File 2
Dim mystr As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Title = "Select File 2"
If .Show = -1 Then
mystr = .SelectedItems.Item(1)
Else
MsgBox Prompt:="Cancelled", Title:="Selection Cancelled"
Exit Sub
End If
End With
sctrl.Range("file2").Value = mystr
End Sub
Private Function getFileName(xStr As String) As String 'Function to get just the file name
Dim slashCount As Byte
Dim startPos As Integer
Dim newStr As String
slashCount = Len(xStr) - Len(Replace(xStr, "\", ""))
xStr = WorksheetFunction.Substitute(xStr, "\", "™", slashCount)
startPos = WorksheetFunction.Search("™", xStr)
xStr = Mid(xStr, startPos + 1, 300)
xStr = WorksheetFunction.Substitute(xStr, ".xl", "™")
xStr = Left(xStr, InStr(1, xStr, "™") - 1)
getFileName = xStr
xStr = Replace(Replace(Replace(Replace(Replace(Replace(Replace(xStr, "/", " "), "\", " "), "*", " "), "[", " "), "]", " "), ":", " "), "?", " ")
End Function
Private Function countPlelimSheets() As Integer
Dim i As Integer, xCount As Integer
For i = 1 To ThisWorkbook.Sheets.Count
If InStr(1, ThisWorkbook.Sheets(i).Name, "PLELIM") > 0 Then
xCount = xCount + 1
End If
Next i
countPlelimSheets = xCount + 1
End Function
Public Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim i As Integer
For i = LBound(arr) To UBound(arr)
If arr(i) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Private Function countInArray(xVal As Variant, xArr As Variant) As Integer
Dim j As Long
For j = LBound(xArr) To UBound(xArr)
If xArr(j) = xVal Then
countInArray = countInArray + 1
End If
Next j
End Function
Private Function ifSheetExists(xName As String) As Boolean
Dim wb As Workbook
Dim i As Integer
Set wb = ThisWorkbook
For i = 1 To wb.Sheets.Count
If wb.Sheets(i).Name = xName Then
ifSheetExists = True
GoTo endf
End If
Next i
ifSheetExists = False
endf:
End Function
Sub highlightRange(xSheet As String, xRange As String)
Application.EnableEvents = False
ThisWorkbook.Sheets(xSheet).Activate
ThisWorkbook.Sheets(xSheet).Range(xRange).EntireRow.Style = "Bad"
ThisWorkbook.Sheets(xSheet).Range(xRange).Activate
Application.EnableEvents = True
End Sub
Sub removehighlight(xSheet As String, xRange As String)
With ThisWorkbook.Sheets(xSheet).Range(xRange).EntireRow
.Interior.Pattern = xlNone
.Interior.TintAndShade = 0
.Interior.PatternTintAndShade = 0
.Font.ColorIndex = xlAutomatic
.Font.TintAndShade = 0
End With
End Sub
Sub returnToSheet()
ThisWorkbook.Sheets(sctrl.Range("lastHome").Value).Activate
End Sub
