Related
Need to compare data in two excel files by FacilityID column. Excel A data has to be aggregated first. In Excel B, FacilityID is unique row.
Tries VLOOKUP. It's getting too confusing. Need VBA solution
Function BrowseWin(mypath As String)
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = GetDir(mypath)
If .Show = -1 Then
BrowseWin = .SelectedItems.Item(1)
Else
BrowseWin = "-"
End If
End With
End Function
Function BrowseMac(mypath As String) As String
sMacScript = "set applescript's text item delimiters to "","" " & vbNewLine & _
"try " & vbNewLine & _
"set theFiles to (choose file " & _
"with prompt ""Please select a file or files"" default location alias """ & _
mypath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"on error errStr number errorNumber" & vbNewLine & _
"return errorNumber " & vbNewLine & _
"end try " & vbNewLine & _
"return theFiles"
BrowseMac = MacScript(sMacScript)
End Function
Function grantFileAccess(filePermissionCandidates)
grantFileAccess = GrantAccessToMultipleFiles(filePermissionCandidates)
End Function
Public Function GetDir(File) As String
If Application.OperatingSystem Like "*Mac*" Then
div = ":"
Else
div = "\"
End If
x = InStrRev(File, div)
If x = 0 Then
GetDir = File
Else
GetDir = Left(File, x)
End If
End Function
Sub ChooseOptima_Click()
Dim startDir As String
startDir = GetDir("/")
If Application.OperatingSystem Like "*Mac*" Then
Path = BrowseMac(startDir)
If Path = "-43" Or Path = "-1700" Then
startDir = MacScript("return (path to documents folder) as String")
Path = BrowseMac(startDir)
End If
Else
Path = BrowseWin(startDir)
End If
If Left(Path, 1) <> "-" Then
Range("Optimafile") = Path
Range("C6").Select
End If
End Sub
Sub ChooseCRC_Click()
Dim startDir As String
startDir = GetDir("/")
If Application.OperatingSystem Like "*Mac*" Then
Path = BrowseMac(startDir)
If Path = "-43" Or Path = "-1700" Then
startDir = MacScript("return (path to documents folder) as String")
Path = BrowseMac(startDir)
End If
Else
Path = BrowseWin(startDir)
End If
If Left(Path, 1) <> "-" Then
Range("Crcfile") = Path
Range("A9").Select
End If
End Sub
Sub LoadReports()
Application.ScreenUpdating = False
With Worksheets("Sheet1")
ResultPath = Range("Optimafile").Value
grantAccessReq = Application.OperatingSystem Like "*Mac*"
If grantAccessReq Then
filePermissionCandidates = Array(NormPath, ExprPath)
grantFileAccess (filePermissionCandidates)
End If
CopyToReport (ResultPath)
End With
End Sub
Sub CopyToReport(OptimaPath As String)
Dim Sheet1, Sheet2 As Worksheet
Dim CrcPath, File1, File2 As String
File1 = Right$(OptimaPath, Len(OptimaPath) - InStrRev(OptimaPath, "\"))
CrcPath = Range("CrcFile").Value
File2 = Right$(CrcPath, Len(CrcPath) - InStrRev(CrcPath, "\"))
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name = "Optima Blue" Then
Sheets("Optima Blue").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "Optima Green" Then
Sheets("Optima Green").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "CRC Limit" Then
Sheets("CRC Limit").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "CRC Usage" Then
Sheets("CRC Usage").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "Result Limit" Then
Sheets("Result Limit").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "Result Usage" Then
Sheets("Result Usage").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "CRC Usage Consolidated" Then
Sheets("CRC Usage Consolidated").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "CRC Limit Consolidated" Then
Sheets("CRC Limit Consolidated").Delete
End If
Next
Application.DisplayAlerts = True
Workbooks.Open (OptimaPath)
Set Sheet1 = Workbooks(File1).Worksheets(1)
MakeOptimaBlueSheet
MakeOptimaGreenSheet
CloseBook (File1)
Workbooks.Open (CrcPath)
Set Sheet2 = Workbooks(File2).Worksheets("CRC")
MakeCRCSheetLimit
MakeCRCSheetUsage
CloseBook (File2)
MakeCRCSheetUsageConsolidated
MakeCRCSheetLimitConsolidated
MakeResultOptimaBlue
MakeResultOptimaGreen
MakeResultLimitReport
MakeResultUsageReport
End Sub
Sub MakeOptimaBlueSheet()
dlastRow = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
Dim rng, aRng, bRng As Range
Dim i, a, hSearch, head, headerCount As Integer
Set FirstCellExclude = ThisWorkbook.Sheets("Sheet1").Range("FirstCellExcludeHeader")
Set SecondCellExclude = ThisWorkbook.Sheets("Sheet1").Range("SecondCellExcludeHeader")
Set OptimaBlueHeaders = ThisWorkbook.Sheets("Sheet1").Range("OptimaBlueHeaders")
Set FindHeaders = ActiveSheet.Range("A1:ZZ1")
Set u = Union(FirstCellExclude, OptimaBlueHeaders, SecondCellExclude)
For Each fcell In FindHeaders
For Each oCell In u
If IsEmpty(fcell) Or IsEmpty(oCell) Then
ElseIf fcell = oCell Then
If Not IsEmpty(strRange) Then strRange = strRange + ","
Cell_Add = Split(fcell.Address, "$")
strRange = strRange + Cell_Add(1) + "1:" + Cell_Add(1) + CStr(dlastRow)
headerCount = headerCount + 1
Else
End If
Next oCell
Next fcell
ActiveSheet.Range(strRange).Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Optima Blue"
ws.Paste
Set ws2 = ThisWorkbook.Sheets("Sheet1")
Set ExcludeRng = ws2.Range("FirstCellValues")
exclLastRow = ws2.Range("FirstCellValues").Rows.Count
Set searchFilterLetter = ws.Range("A1:Z1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = FirstCellExclude.Value Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Debug.Print FilterLetter
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
Set searchFilterLetter = ws.Range("A1:Z1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = SecondCellExclude.Value Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Debug.Print FilterLetter
Else
End If
Next gcell
Set ExcludeRng2 = ws2.Range("SecondCellValues")
exclLastRow2 = ws2.Range("SecondCellValues").Rows.Count
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow2 To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng2.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng2.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
ws.Range("G1") = "Optima Blue Total"
ws.Range("G2").Formula = "=B2+C2+D2+E2+F2"
ws.Range("G2").Copy
ws.Range("G3:G" & dlastRow & " ").PasteSpecial (xlPasteAll)
ws.Range("G2:G" & dlastRow & " ").NumberFormat = "#,##0"
For Each rng In ws.Range("G2:G" & dlastRow & " ")
If rng.HasFormula Then
rng.Formula = rng.Value
End If
Next rng
ws.Range("B:F").Delete
End With
End Sub
Sub MakeOptimaGreenSheet()
dlastRow = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
Dim rng As Range
Dim i, a, hSearch, head, headerCount As Integer
Set FirstCellExclude = ThisWorkbook.Sheets("Sheet1").Range("FirstCellExcludeHeader")
Set SecondCellExclude = ThisWorkbook.Sheets("Sheet1").Range("SecondCellExcludeHeader")
Set OptimaGreenHeaders = ThisWorkbook.Sheets("Sheet1").Range("OptimaGreenHeaders")
Set FindHeaders = ActiveSheet.Range("A1:ZZ1")
Set u = Union(FirstCellExclude, SecondCellExclude, OptimaGreenHeaders)
For Each fcell In FindHeaders
For Each oCell In u
If IsEmpty(fcell) Or IsEmpty(oCell) Then
ElseIf fcell = oCell Then
If Not IsEmpty(strRange) Then strRange = strRange + ","
Cell_Add = Split(fcell.Address, "$")
strRange = strRange + Cell_Add(1) + "1:" + Cell_Add(1) + CStr(dlastRow)
headerCount = headerCount + 1
Else
End If
Next oCell
Next fcell
ActiveSheet.Range(strRange).Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Optima Green"
ws.Paste
Set ws2 = ThisWorkbook.Sheets("Sheet1")
Set ExcludeRng = ws2.Range("FirstCellValues")
exclLastRow = ws2.Range("FirstCellValues").Rows.Count
Set searchFilterLetter = ws.Range("A1:Z1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = FirstCellExclude.Value Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Debug.Print FilterLetter
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
Set searchFilterLetter = ws.Range("A1:Z1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = SecondCellExclude.Value Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Debug.Print FilterLetter
Else
End If
Next gcell
Set ExcludeRng2 = ws2.Range("SecondCellValues")
exclLastRow2 = ws2.Range("SecondCellValues").Rows.Count
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow2 To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng2.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng2.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
ws.Range("G1") = "Optima Green Total"
ws.Range("G2").Formula = "=B2+C2+D2+E2+F2"
ws.Range("G2").Copy
ws.Range("G3:G" & dlastRow & " ").PasteSpecial (xlPasteAll)
ws.Range("G2:G" & dlastRow & " ").NumberFormat = "#,##0"
For Each rng In ws.Range("G2:G" & dlastRow & " ")
If rng.HasFormula Then
rng.Formula = rng.Value
End If
Next rng
ws.Range("B:F").Delete
End With
End Sub
Sub MakeCRCSheetLimit()
dlastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Dim rng As Range
Dim i, a, hSearch, head, headerCount As Integer
Set FirstCrcFilter = ThisWorkbook.Sheets("Sheet1").Range("FirstCrcFilterHeader")
Set SecondCrcFilter = ThisWorkbook.Sheets("Sheet1").Range("SecondCrcFilterHeader")
Set CrcLimitHeaders = ThisWorkbook.Sheets("Sheet1").Range("CrcLimitHeaders")
Set FindHeaders = ActiveSheet.Range("A1:ZZ1")
Set u = Union(CrcLimitHeaders, FirstCrcFilter, SecondCrcFilter)
For Each fcell In FindHeaders
For Each oCell In u
If IsEmpty(fcell) Or IsEmpty(oCell) Then
ElseIf fcell = oCell Then
If Not IsEmpty(strRange) Then strRange = strRange + ","
Cell_Add = Split(fcell.Address, "$")
strRange = strRange + Cell_Add(1) + "1:" + Cell_Add(1) + CStr(dlastRow)
headerCount = headerCount + 1
Else
End If
Next oCell
Next fcell
ActiveSheet.Range(strRange).Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "CRC Limit"
ws.Paste
Set ws2 = ThisWorkbook.Sheets("Sheet1")
Set ExcludeRng = ws2.Range("FirstCrcFilterValues")
exclLastRow = ws2.Range("FirstCrcFilterValues").Rows.Count
Set searchFilterLetter = ws.Range("A1:Zz1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = FirstCrcFilter Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
Set ExcludeRng2 = ws2.Range("SecondCrcFilterValues")
exclLastRow2 = ExcludeRng2.Rows.Count
Set searchFilterLetter = ws.Range("A1:Zz1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = SecondCrcFilter Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow2 To 1 Step -1
Debug.Print ws.Cells(i, FilterLetter), ExcludeRng2.Cells(a, 1)
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng2.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng2.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
ws.Range("B2:B" & dlastRow & " ").NumberFormat = "#,##0"
End With
End Sub
Sub MakeCRCSheetUsage()
dlastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Dim rng As Range
Dim i, a, hSearch, head, headerCount As Integer
Set FirstCrcFilter = ThisWorkbook.Sheets("Sheet1").Range("FirstCrcFilterHeader")
Set SecondCrcFilter = ThisWorkbook.Sheets("Sheet1").Range("SecondCrcFilterHeader")
Set CrcLimitHeaders = ThisWorkbook.Sheets("Sheet1").Range("CrcUsageHeaders")
Set FindHeaders = ActiveSheet.Range("A1:ZZ1")
Set u = Union(CrcLimitHeaders, FirstCrcFilter, SecondCrcFilter)
For Each fcell In FindHeaders
For Each oCell In u
If IsEmpty(fcell) Or IsEmpty(oCell) Then
ElseIf fcell = oCell Then
If Not IsEmpty(strRange) Then strRange = strRange + ","
Cell_Add = Split(fcell.Address, "$")
strRange = strRange + Cell_Add(1) + "1:" + Cell_Add(1) + CStr(dlastRow)
headerCount = headerCount + 1
Else
End If
Next oCell
Next fcell
ActiveSheet.Range(strRange).Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "CRC Usage"
ws.Paste
Set ws2 = ThisWorkbook.Sheets("Sheet1")
Set ExcludeRng = ws2.Range("FirstCrcFilterValues")
exclLastRow = ws2.Range("FirstCrcFilterValues").Rows.Count
Set searchFilterLetter = ws.Range("A1:Zz1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = FirstCrcFilter Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
Set ExcludeRng2 = ws2.Range("SecondCrcFilterValues")
exclLastRow2 = ExcludeRng2.Rows.Count
Set searchFilterLetter = ws.Range("A1:Zz1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = SecondCrcFilter Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow2 To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng2.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng2.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
ws.Range("B2:B" & dlastRow & " ").NumberFormat = "#,##0"
End With
End Sub
Sub MakeCRCSheetUsageConsolidated()
Dim CRCSheetUsageConsolidated As Worksheet, Result As Worksheet
Dim ConsolidateRangeArray As Variant
Set CRCSheetUsageConsolidated = Sheets("CRC Usage")
CRCSheetUsageConsolidated.Select
dlastRow = CRCSheetUsageConsolidated.Cells(Rows.Count, "A").End(xlUp).Row
CRCSheetUsageConsolidated.Select
CRCSheetUsageConsolidated.Range("A1:A" & dlastRow & " ").Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "CRC Usage Consolidated"
Selection.Consolidate Sources:= _
"'CRC Usage'!R1C1:R" & dlastRow & "C2", Function:= _
xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End With
End Sub
Sub MakeCRCSheetLimitConsolidated()
Dim CRCSheetLimitConsolidated As Worksheet, Result As Worksheet
Dim ConsolidateRangeArray As Variant
Set CRCSheetLimitConsolidated = Sheets("CRC Limit")
CRCSheetLimitConsolidated.Select
dlastRow = CRCSheetLimitConsolidated.Cells(Rows.Count, "A").End(xlUp).Row
CRCSheetLimitConsolidated.Select
CRCSheetLimitConsolidated.Range("A1:A" & dlastRow & " ").Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "CRC Limit Consolidated"
Selection.Consolidate Sources:= _
"'CRC Limit'!R1C1:R" & dlastRow & "C2", Function:= _
xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End With
End Sub
Sub MakeResultOptimaBlue()
Dim OptimaBlue As Worksheet, Result As Worksheet
Dim ConsolidateRangeArray As Variant
Set OptimaBlue = Sheets("Optima Blue")
OptimaBlue.Select
dlastRow = OptimaBlue.Cells(Rows.Count, "A").End(xlUp).Row
OptimaBlue.Range("A1:A" & dlastRow & " ").Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Result Limit"
Selection.Consolidate Sources:= _
"'Optima Blue'!R1C1:R" & dlastRow & "C2", Function:= _
xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End With
End Sub
Sub MakeResultOptimaGreen()
Dim OptimaGreen As Worksheet, Result As Worksheet
Dim ConsolidateRangeArray As Variant
Set OptimaGreen = Sheets("Optima Green")
OptimaGreen.Select
dlastRow = OptimaGreen.Cells(Rows.Count, "A").End(xlUp).Row
OptimaGreen.Range("A1:A" & dlastRow & " ").Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Result Usage"
Selection.Consolidate Sources:= _
"'Optima Green'!R1C1:R" & dlastRow & "C2", Function:= _
xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End With
End Sub
Sub MakeResultLimitReport()
Dim shOptima As Worksheet, shCrc As Worksheet, shResult As Worksheet
Dim aRng, bRng As Range
Dim Fnd As Range
Dim ListObject As ListObject
Set shOptima = Sheets("Optima Blue")
Set shCrc = Sheets("CRC Limit Consolidated")
Set shResult = Sheets("Result Limit")
bLastRow = shResult.Cells(Rows.Count, "A").End(xlUp).Row
aLastRow = shCrc.Cells(Rows.Count, "A").End(xlUp).Row
Set aRng = shCrc.Range("A2:A" & aLastRow & "") '127
Set bRng = shResult.Range("A2:A" & bLastRow & "") '71
For Each aCell In aRng
For Each bcell In bRng
If aCell Is Nothing Or bcell Is Nothing Then
ElseIf aCell.Text = bcell.Text Then
bcell.Offset(0, 2).Formula = "='CRC Limit Consolidated'!" & aCell.Offset(0, 1).Address & " "
Else
End If
Next bcell
Next aCell
shResult.Range("D2").Formula = "=IF(B2=0,IF(C2=0,0,abs(((B2-C2)/C2)*100)),abs(((C2-B2)/B2)*100))"
shResult.Range("D2").Copy
shResult.Range("D3:D" & bLastRow).PasteSpecial (xlPasteAll)
shResult.Range("D2:D" & bLastRow).NumberFormat = "#,##0"
shResult.Range("D2:D" & bLastRow).NumberFormat = "#,##0.00"
shResult.Activate
shResult.Range("A1") = "Facility ID"
shResult.Range("D1") = "Diff in percent"
shResult.Range("C1") = "CRC Limit"
shResult.Range("B2:D" & bLastRow & " ").NumberFormat = "#,##0"
shOptima.Range("E1:g1").Interior.ColorIndex = 35
Range("A1:G" & bLastRow).EntireColumn.AutoFit
Range("A2:D" & bLastRow).Sort key1:=Range("D2:D" & bLastRow), order1:=xlDescending, Header:=xlNo
Set ListObject = ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes)
With ListObject
.Name = "Table4"
.TableStyle = "TableStyleMedium5"
End With
End Sub
Sub MakeResultUsageReport()
Dim shOptima As Worksheet, shCrc As Worksheet, shResult As Worksheet
Dim aRng, bRng As Range
Dim Fnd As Range
Dim ListObject As ListObject
Set shOptima = Sheets("Optima Green")
Set shCrc = Sheets("CRC Usage Consolidated")
Set shResult = Sheets("Result Usage")
bLastRow = shResult.Cells(Rows.Count, "A").End(xlUp).Row
aLastRow = shCrc.Cells(Rows.Count, "A").End(xlUp).Row
Set aRng = shCrc.Range("A2:A" & aLastRow & "")
Set bRng = shResult.Range("A2:A" & bLastRow & "")
For Each aCell In aRng
For Each bcell In bRng
If aCell Is Nothing Or bcell Is Nothing Then
ElseIf aCell.Text = bcell.Text Then
bcell.Offset(0, 2).Formula = "='CRC Usage Consolidated'!" & aCell.Offset(0, 1).Address & " "
Else
End If
Next bcell
Next aCell
shResult.Range("D2").Formula = "=IF(B2=0,IF(C2=0,0,abs(((B2-C2)/C2)*100)),abs(((C2-B2)/B2)*100))"
shResult.Range("D2").Copy
shResult.Range("D3:D" & bLastRow).PasteSpecial (xlPasteAll)
shResult.Range("D2:D" & bLastRow).NumberFormat = "#,##0"
shResult.Range("D2:D" & bLastRow).NumberFormat = "#,##0.00"
shResult.Activate
shResult.Range("A1") = "Facility ID"
shResult.Range("D1") = "Diff in percent"
shResult.Range("C1") = "CRC Usage"
shResult.Range("B2:D" & bLastRow & " ").NumberFormat = "#,##0"
shOptima.Range("E1:g1").Interior.ColorIndex = 35
Range("A1:G" & bLastRow).EntireColumn.AutoFit
Range("A2:D" & bLastRow).Sort key1:=Range("D2:D" & bLastRow), order1:=xlDescending, Header:=xlNo
Set ListObject = ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes)
With ListObject
.Name = "Table4"
.TableStyle = "TableStyleMedium4"
End With
Application.ScreenUpdating = True
End Sub
Sub CloseBook(File As String)
Workbooks(File).Close savechanges:=False
End Sub
I am looking for VBA to refresh Nielsen Nitro range.
Nielsen Nitro is an application to extract data from the Database. Also range is called Blueberry range to refresh the data
I've tried to use below VBA, but it was not working
Dim acnNitro As New ACNNITRO
Dim acnNitroUpdate As ACNielsenNitro.ACNNitroUpdate
Dim WS As Worksheet
Dim bret as Boolean
acnNitro.ParentApp = Application
acnNitroUpdate = acnNitro.ACNNitroUpdate
WS = ActiveSheet 'or Set WS = WorkSheets("My Sheet")
bret = acnNitroUpdate.UpdateAllNRanges(WS, ntrSelectGet)
acnNitro = Nothing
acnNitroUpdate = Nothing
WB = Nothing
screenshot
I have also provided screenshot for the range.
Can you please suggest me for VBA code?
I have written a similar code for a project, find code below. It might help you!
Public Sub NeilsenRefresh()
Dim str_RngDesc As Variant
Dim bRet As Boolean
Dim RngObj As NITRORange
Dim acnNITROUpdt As Object
Dim acnNITRO As Object
Dim NRangeObj As NITRORange
Dim cRange As Object
Dim Bubble As String
Set acnNITRO = CreateObject("ACNielsenNitro.ACNNitro")
Set acnNITRO.ParentApp = ActiveWorkbook.Application
Set acnNITROUpdt = acnNITRO.ACNNitroUpdate
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("Macro")
WkbName = .Range("G9").Value
Path = .Range("G12").Value
Bubble = .Range("G15").Value
Atribute = .Range("G18").Value
WkList = .Range("G6").Value
End With
'Sheets("Data").Activate
With ThisWorkbook.Sheets("Data")
lr = .Range("A1048576").End(xlUp).Row
If lr > 1 Then
.Range("Q1:Q" & lr).ClearContents
.Range("A2:A" & lr).ClearContents
.Range("B3:C" & lr).ClearContents
.Range("D2:D" & lr).ClearContents
.Range("R2:R" & lr).ClearContents
.Range("S2:S" & lr).ClearContents
End If
Set WkbList = Workbooks.Open(Path & "\" & WkList & ".xlsx")
Set wks = WkbList.Sheets("Sheet1")
lrw = wks.Range("A1048576").End(xlUp).Row
wks.Range("A2:A" & lrw).Copy
.Range("A2").PasteSpecial Paste:=xlPasteValues
wks.Range("B2:B" & lrw).Copy
.Range("D2").PasteSpecial Paste:=xlPasteValues
lr = .Range("A1048576").End(xlUp).Row
.Range("B2:C" & lr).FillDown
.Calculate
Set wksmiss = ThisWorkbook.Sheets("Missing Records")
lrw = wksmiss.Range("A1048576").End(xlUp).Row
If lrw > 1 Then wksmiss.Range("A2:B" & lrw).ClearContents
.Range("A1:D" & lr).AutoFilter Field:=2, Criteria1:="#N/A"
lrw = .Range("A1048576").End(xlUp).Row
If lrw > 1 Then
.Range("B2:B" & lrw).SpecialCells(xlCellTypeVisible).Copy
wksmiss.Range("A2").PasteSpecial Paste:=xlPasteValues
.Range("D2:D" & lrw).SpecialCells(xlCellTypeVisible).Copy
wksmiss.Range("B2").PasteSpecial Paste:=xlPasteValues
.Range("A2:D" & lrw).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
End If
.Range("A1:D" & lr).AutoFilter
.Range("B2:C" & lr).FillDown
.Calculate
.Calculate
.Range("A2:A" & lr).Copy
.Range("Q1").PasteSpecial Paste:=xlPasteValues
.Range("Q1:Q" & lr).RemoveDuplicates Columns:=1, Header:=xlNo
lrd = .Range("Q1048576").End(xlUp).Row
.Range("R1:R" & lrd).FillDown
.Range("S1:S" & lrd).FillDown
.Range("A1").Value = "Cum Name"
.Calculate
For i = 1 To lrd
CumName = .Range("Q" & i).Value
Cnt = .Range("R" & i).Value
FstIndex = .Range("S" & i).Value
RowNo = FstIndex + Cnt - 1
val1 = .Range("C" & RowNo).Value
If CumConcat = "" Then
CumConcat = val1 & ","
Else
val1 = Replace(val1, "MKT", "")
CumConcat = CumConcat & val1 & ","
End If
Next
End With
Set wkb = Workbooks.Open(Path & "\" & WkbName & ".xlsx")
Set RngObj = acnNITRO.ACNRangeUtility.GetNRange(Bubble, ActiveWorkbook)
RngObj.DimCount = 4
RngObj.DimIndex = Atribute
RngObj.DimGetString = CumConcat
str_RngDesc = RngObj.RangeDescription
Set acnNITROUpdt = acnNITRO.ACNNitroUpdate
bRet = acnNITROUpdt.UpdateNRange(ActiveWorkbook, Bubble, 0)
WkbList.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
ThisWorkbook.Sheets("Macro").Activate
MsgBox "Nielsen Refresh Completed", vbInformation
End Sub
I'm trying to plot huge series of data using for next statement. However, I don't know why the secondary axis is not being plotted by the following code:
Sub IndividualPlots()
Dim TF As Worksheet
Dim OIL As Worksheet
Dim WTR As Worksheet
Dim TG As Worksheet
Dim GL As Worksheet
Dim RG As Worksheet
Dim WC As Worksheet
Dim MM As Worksheet
Dim VRRStart As Worksheet
Dim NewWs As Worksheet
Dim cht As Chart
Dim chtobj As ChartObject
Dim Lastcol As Long
Dim Currcol As Long
Set TF = ThisWorkbook.Worksheets("TF")
Set OIL = ThisWorkbook.Worksheets("OIL")
Set WTR = ThisWorkbook.Worksheets("WTR")
Set TG = ThisWorkbook.Worksheets("TG")
Set GL = ThisWorkbook.Worksheets("GL")
Set RG = ThisWorkbook.Worksheets("RG")
Set WC = ThisWorkbook.Worksheets("RG")
Set MM = ThisWorkbook.Worksheets("Master Monitor")
Set VRRStart = ThisWorkbook.Worksheets("VRRStart")
Application.ScreenUpdating = False
ClrChts
Lastcol = TF.Cells(5, Columns.Count).End(xlToLeft).Column
For Currcol = 2 To Lastcol
Set cht = ThisWorkbook.Charts.Add
'VRRstart Plot
With cht.SeriesCollection.NewSeries
.Name = "=" & VRRStart.Name & "!R1C2"
.Values = "=" & VRRStart.Name & "!R" & 7 & "C" & Currcol & ":R" & 8 & "C" & Currcol
.XValues = "=" & VRRStart.Name & "!R" & 7 & "C1:R" & 8 & "C1"
.Border.Color = RGB(0, 0, 0)
.Format.Line.Weight = 3
End With
'OIL Plot
With cht.SeriesCollection.NewSeries
.Name = "=" & OIL.Name & "!R1C2"
.Values = "=" & OIL.Name & "!R" & 6 & "C" & Currcol & ":R" & 96 & "C" & Currcol
.XValues = "=" & OIL.Name & "!R" & 6 & "C1:R" & 96 & "C1"
.Border.Color = RGB(153, 204, 0)
End With
'WTR Plot
With cht.SeriesCollection.NewSeries
.AxisGroup = 2
.Name = "=" & WTR.Name & "!R1C2"
.Values = "=" & WTR.Name & "!R" & 6 & "C" & Currcol & ":R" & 96 & "C" & Currcol
.XValues = "=" & WTR.Name & "!R" & 6 & "C1:R" & 96 & "C1"
.Border.Color = RGB(0, 0, 0)
End With
'TG Plot
With cht.SeriesCollection.NewSeries
.AxisGroup = 2
.Name = "=" & TG.Name & "!R1C2"
.Values = "=" & TG.Name & "!R" & 6 & "C" & Currcol & ":R" & 96 & "C" & Currcol
.XValues = "=" & TG.Name & "!R" & 6 & "C1:R" & 96 & "C1"
.Border.Color = RGB(255, 0, 0)
End With
'WC Plot
With cht.SeriesCollection.NewSeries
.Name = "=" & WC.Name & "!R1C2"
.Values = "=" & WC.Name & "!R" & 6 & "C" & Currcol & ":R" & 96 & "C" & Currcol
.XValues = "=" & WC.Name & "!R" & 6 & "C1:R" & 96 & "C1"
.Border.Color = RGB(255, 153, 0)
End With
With cht
.ChartType = xlXYScatterLines
.Axes(xlCategory).TickLabels.NumberFormat = "m/d/yy"
.HasTitle = True
.ChartTitle.Text = TF.Cells(4, Currcol)
.ChartTitle.Font.Size = 10
.HasLegend = True
.Legend.Position = xlLegendPositionBottom
.Location Where:=xlLocationAsObject, Name:=MM.Name
End With
'.Axes(xlCategory).MinimumScaleIsAuto = False
'.Axes(xlCategory).MinimumScale = 42248
'.Axes(xlCategory).MaximumScaleIsAuto = False
'.Axes(xlCategory).MaximumScale = 42338
'.Axes(xlValue).MinimumScaleIsAuto = False
'.Axes(xlValue).MinimumScale = 0
'.Axes(xlValue).MaximumScaleIsAuto = False
'.Axes(xlValue).MaximumScale = 860
Next Currcol
Application.ScreenUpdating = True
End Sub
Other sub :
Sub ClrChts()
Dim wks As Worksheet
For Each wks In Worksheets
If wks.ChartObjects.Count > 0 Then
wks.ChartObjects.Delete
End If
Next wks
End Sub
Is it an issue of using charts or chartobject add function?
Not sure if my title properly describes what I am try to do, but here goes:
I have a macro which opens a .csv file and looks for headers. Like this:
With Application.WorksheetFunction
ValArray(1) = .Match(ptOne, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(2) = .Match(ptTwo, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(3) = .Match(ptThree, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(4) = .Match(ptFour, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(5) = .Match(ptFive, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(6) = .Match(ptSix, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(7) = .Match(ptSeven, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(8) = .Match(ptEight, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
End With
The user defines the header name in the spreadsheet where the macro button is kept which is assigned to the variable ptOne, ptTwo and so on. In the macro spreadsheet, using the above code, the user can define 8 variables headers, but I'd like them to be able to assign 7 or 10 variables in the macro worksheet.
I'm using counta elsewhere to count the number of headers the user assigns in the spreadsheet. I'd like to use something like an IF Statement to find as many or as few headers as the user defines.
Any ideas? I'm having a bit of trouble describing this, but please ask if I'm confusing. Thanks in advance for any suggestions.
Its a little much to sift through, but here is the full code:
Sub gasCollectionSystem()
Dim RawWbName As String
Dim RawWb As Workbook
Dim RawWs As Worksheet
Dim NewWb As Workbook
Dim NewWs As Worksheet
Dim ValArray(1 To 25) As Long
Dim Cel As Range
Dim r As Range
Dim DateTime As Date
Dim SearchRange As Range
Dim FindRow As Range
Dim monitorRange As Range
Dim numMonitorPts As Integer
'Dim ptOne As Range
'Dim ptTwo As Range
'Dim ptThree As Range
'Dim ptFour As Range
'Dim ptFive As Range
'Dim ptSix As Range
'Dim ptSeven As Range
'Dim ptEight As Range
RawWbName = Application.GetOpenFilename("CSV Files (*.csv), *.csv")
Set ptOne = Range("H4")
Set ptTwo = Range("I4")
Set ptThree = Range("J4")
Set ptFour = Range("K4")
Set ptFive = Range("L4")
Set ptSix = Range("M4")
Set ptSeven = Range("N4")
Set ptEight = Range("O4")
Set lblOne = Range("H5")
Set lblTwo = Range("I5")
Set lblThree = Range("J5")
Set lblFour = Range("K5")
Set lblFive = Range("L5")
Set lblSix = Range("M5")
Set lblSeven = Range("N5")
Set lblEight = Range("O5")
Set frmtOne = Range("H6")
Set frmtTwo = Range("I6")
Set frmtThree = Range("J6")
Set frmtFour = Range("K6")
Set frmtFive = Range("L6")
Set frmtSix = Range("M6")
Set frmtSeven = Range("N6")
Set frmtEight = Range("O6")
Set monitorRange = Range("H4:W4")
numMonitorPts = Application.WorksheetFunction.CountA(monitorRange)
MsgBox (numMonitorPts)
Workbooks.Open RawWbName, local:=True
Set RawWb = ActiveWorkbook
Set RawWs = ActiveSheet
Set NewWb = Workbooks.Add
Set NewWs = ActiveSheet
RawWb.Activate
With RawWb.Sheets(RawWs.Name)
Set SearchRange = .Range("A1", Range("A65536").End(xlUp))
Set FindRow = SearchRange.Find("ID", LookIn:=xlValues, lookat:=xlWhole)
End With
NewWb.Sheets(NewWs.Name).Cells(1, 1) = RawWs.Cells(1, 1)
'RawWbName = Application.GetOpenFilename("CSV Files (*.csv), *.csv")
With Application.WorksheetFunction
ValArray(1) = .Match(ptOne, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(2) = .Match(ptTwo, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(3) = .Match(ptThree, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(4) = .Match(ptFour, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(5) = .Match(ptFive, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(6) = .Match(ptSix, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(7) = .Match(ptSeven, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
ValArray(8) = .Match(ptEight, RawWs.Range(("a" & FindRow.Row) & ":" & ("iv" & FindRow.Row)), 0)
End With
'do ID
RawWs.Range(("a" & FindRow.Row) & ":a65536").Copy
NewWs.Activate
NewWs.Range("a1").Select
NewWs.Paste
Range("a1").Select
ActiveCell.FormulaR1C1 = "01 Asset ID"
'do DateTime
RawWs.Range(("b" & FindRow.Row) & ":b65536").Copy
NewWs.Range("b1").Select
NewWs.Paste
Columns("B:B").Select
Selection.NumberFormat = "dd-mm-yyyy h:mm"
Range("b1").Select
ActiveCell.FormulaR1C1 = "02 Date/Time"
'do Value1
RawWb.Activate
Range(RawWs.Cells(FindRow.Row + 1, ValArray(1)), RawWs.Cells(65536, ValArray(1))).Select
Selection.Copy
NewWb.Activate
NewWs.Range("c2").Select
NewWs.Paste
Columns("C:C").Select
Selection.NumberFormat = frmtOne
Range("c1").Select
ActiveCell.FormulaR1C1 = "03 " & lblOne
'do Value2
Range(RawWs.Cells(FindRow.Row + 1, ValArray(2)), RawWs.Cells(65536, ValArray(2))).Copy
NewWs.Range("d2").Select
NewWs.Paste
Columns("d:d").Select
Selection.NumberFormat = frmtTwo
Range("d1").Select
ActiveCell.FormulaR1C1 = "04 " & lblTwo
'do Value3
Range(RawWs.Cells(FindRow.Row + 1, ValArray(3)), RawWs.Cells(65536, ValArray(3))).Copy
NewWs.Range("e2").Select
NewWs.Paste
Columns("e:e").Select
Selection.NumberFormat = frmtThree
Range("e1").Select
ActiveCell.FormulaR1C1 = "05 " & lblThree
'do Value4
Range(RawWs.Cells(FindRow.Row + 1, ValArray(4)), RawWs.Cells(65536, ValArray(4))).Copy
NewWs.Range("f2").Select
NewWs.Paste
Set r = Intersect(NewWs.Range("f3:f65536"), NewWs.UsedRange)
If Not r Is Nothing Then
For Each Cel In r.Cells
If Cel < 0 Then
Cel.Value = 0
End If
Next Cel
End If
Columns("f:f").Select
Selection.NumberFormat = frmtFour
Range("f1").Select
ActiveCell.FormulaR1C1 = "06 " & lblFour
'do Value5
Range(RawWs.Cells(FindRow.Row + 1, ValArray(5)), RawWs.Cells(65536, ValArray(5))).Copy
NewWs.Range("g2").Select
NewWs.Paste
Columns("g:g").Select
Selection.NumberFormat = frmtFive
Range("g1").Select
ActiveCell.FormulaR1C1 = "07 " & lblFive
'do Value6
Range(RawWs.Cells(FindRow.Row + 1, ValArray(6)), RawWs.Cells(65536, ValArray(6))).Copy
NewWs.Range("h2").Select
NewWs.Paste
Columns("h:h").Select
Selection.NumberFormat = frmtSix
Range("h1").Select
ActiveCell.FormulaR1C1 = "08 " & lblSix
'do Value7
Range(RawWs.Cells(FindRow.Row + 1, ValArray(7)), RawWs.Cells(65536, ValArray(7))).Copy
NewWs.Range("i2").Select
NewWs.Paste
Columns("i:i").Select
Selection.NumberFormat = frmtSeven
Range("i1").Select
ActiveCell.FormulaR1C1 = "09 " & lblSeven
'do Value8
Range(RawWs.Cells(FindRow.Row + 1, ValArray(8)), RawWs.Cells(65536, ValArray(8))).Copy
NewWs.Range("j2").Select
NewWs.Paste
Columns("j:j").Select
Selection.NumberFormat = frmtEight
Range("j1").Select
ActiveCell.FormulaR1C1 = "10 " & lblEight
Rows("2:2").Select
Selection.Delete Shift:=xlUp
NewWb.SaveAs Filename:=RawWb.Path & "\Landfill_Gs Ext " & RawWb.Name, FileFormat:=xlCSV
' NewWb.Close
RawWb.Close
End Sub
Thanks!
Compiled but not tested - this might give you some ideas.
Sub gasCollectionSystem()
Dim RawWbName As String
Dim RawWb As Workbook
Dim RawWs As Worksheet
Dim NewWb As Workbook
Dim NewWs As Worksheet
Dim Cel As Range
Dim r As Range
Dim DateTime As Date
Dim SearchRange As Range
Dim FindRow As Range
Dim monitorRange As Range
Dim numMonitorPts As Integer
Const MAX_BLANK As Long = 10
Dim ptOne As Range
Dim colName As String, colLabel As String, colFormat As String
Dim numBlank As Long, f As Range, pasteCol As Long
Dim rngCopy As Range
RawWbName = Application.GetOpenFilename("CSV Files (*.csv), *.csv")
Set RawWb = Workbooks.Open(RawWbName, local:=True)
Set RawWs = RawWb.Sheets(1)
Set SearchRange = RawWs.Range("A1", Range("A65536").End(xlUp))
Set FindRow = SearchRange.Find("ID", LookIn:=xlValues, lookat:=xlWhole)
'check we found the "ID" row...
If FindRow Is Nothing Then
MsgBox "Value 'ID' not found in ColA", vbCritical
Exit Sub
Else
Set FindRow = FindRow.EntireRow
End If
'set up new workbook
Set NewWb = Workbooks.Add()
Set NewWs = NewWb.Sheets(1)
NewWb.Sheets(NewWs.Name).Cells(1, 1) = RawWs.Cells(1, 1)
'copy first two columns
DoCopy RawWs.Range(("A" & FindRow.Row) & ":A65536"), _
NewWs.Range("A1"), "01 Asset ID", ""
DoCopy RawWs.Range(("B" & FindRow.Row) & ":B65536"), _
NewWs.Range("B1"), "02 Date/Time", "dd-mm-yyyy h:mm"
'add your actual sheet name in the next line...
Set ptOne = ThisWorkbook.Sheets("Setup").Range("H4")
numBlank = 0
pasteCol = 3
Do While numBlank < MAX_BLANK
colName = Trim(ptOne.Value)
colLabel = Trim(ptOne.Offset(1, 0).Value)
colFormat = Trim(ptOne.Offset(2, 0).Value)
If Len(colName) > 0 Then
Set f = FindRow.Find(colName, , xlValues, xlWhole)
If Not f Is Nothing Then
Set rngCopy = f.Parent.Range(f, _
f.Parent.Cells(Rows.Count, f.Column).End(xlUp))
'copy the data
DoCopy rngCopy, NewWs.Cells(1, pasteCol), _
pasteCol & " " & colLabel, colFormat
pasteCol = pasteCol + 1 'new column over for pasting
End If
numBlank = 0
Else
numBlank = numBlank + 1
End If
Set ptOne = ptOne.Offset(0, 1) 'next config column
Loop
NewWb.SaveAs Filename:=RawWb.Path & "\Landfill_Gs Ext " & RawWb.Name, FileFormat:=xlCSV
' NewWb.Close
RawWb.Close
End Sub
'generic copy/format sub
'doesn't handle your "value4" special formatting though
Sub DoCopy(rngSrc As Range, rngPaste As Range, colLabel As String, fmt As String)
rngSrc.Copy rngPaste
rngPaste.Value = colLabel
If Len(fmt) > 0 Then
Application.Intersect(rngPaste.EntireColumn, _
rngPaste.Parent.UsedRange).NumberFormat = fmt
End If
End Sub
I've seen numerous questions on the issue but none of the solutions fit my situation (I think) so any help is appreciated. I receive the error when setting the value of the LR integer variable. As with many others having this issue, it only fails the second time the subroutine is run.
Sub SaveEmailAttachments()
' Creates each variable to be used
Dim xlApp As Excel.Application, xlWB As Excel.Workbook, xlAtt As Excel.Workbook
Dim olItem As Outlook.MailItem
Dim LR As Integer, NR As Integer, j As Integer, intDir As Integer, random As Integer
' Path to the HWB Master template to be used
Const strPath As String = "C:\Users\dkirksey\Documents\SOF\SOF Station HWB Master w Macro.xlsm"
' If no emails are selected, present an error and exit
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
' Creates a new Excel application
On Error Resume Next
Set xlApp = New Excel.Application
xlApp.Visible = False
'Opens the Excel workbook
On Error GoTo 0
Set xlWB = xlApp.Workbooks.Open(strPath)
'Creates a new directory to store today's information
intDir = (fIsFileDIR("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy"), vbDirectory))
If intDir = 0 Then
MkDir ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy"))
MkDir ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & "\HWBs")
'Process each selected email
For Each olItem In Application.ActiveExplorer.Selection
j = j + 1
For cnt = 1 To olItem.Attachments.Count
If Right(olItem.Attachments(1).FileName, 4) = "xlsx" Or Right(olItem.Attachments(1).FileName, 3) = "xls" Or Right(olItem.Attachments(1).FileName, 4) = "xlsm" Then
olItem.Attachments(cnt).SaveAsFile ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & "\HWBs\" _
& Format(Now, "mmddyy") & " " & j & olItem.Attachments(cnt).DisplayName)
Set xlAtt = xlApp.Workbooks.Open("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & "\HWBs\" _
& Format(Now, "mmddyy") & " " & j & olItem.Attachments(cnt).DisplayName)
xlAtt.Activate
If xlAtt.ActiveSheet.Range("A3").Value = "HWB" And xlAtt.ActiveSheet.Range("B3").Value = "Instruction (optional)" And xlAtt.ActiveSheet.Range("C3").Value = "Route (optional)" Then
LR = xlAtt.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
xlAtt.ActiveSheet.Range("A4:C4" & LR).Select
Selection.Copy
xlWB.Activate
xlWB.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial xlPasteValues
xlWB.ActiveSheet.Cells(1, 1).Activate
End If
xlApp.DisplayAlerts = False
xlAtt.Close SaveChanges:=False
Else
olItem.Categories = "Purple Category"
End If
Next
Next olItem
j = 4
LR = xlWB.ActiveSheet.UsedRange.Rows.Count
Do Until j > LR
If IsNumeric(Cells(j, 1)) = False Then
Cells(j, 1).EntireRow.Delete
LR = LR - 1
ElseIf Cells(j, 1).Value = "" Then
Cells(j, 1).EntireRow.Delete
LR = LR - 1
Else
j = j + 1
End If
Loop
xlWB.SaveAs ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & "\" & Format(Now, "mmddyy") & " Complete HWB List")
Else
ans = MsgBox("You have already run SOF today, would you like to continue anyway?", vbYesNo)
If ans = vbYes Then
random = Int((9999 - 100 + 1) * Rnd + 100)
MkDir ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random)
MkDir ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random & "\HWBs")
MsgBox "Your new folder is titled " & Format(Now, "mmddyy") & random & ", it is located in the Documents\SOF\HWB Files directory"
'Process each selected email
For Each olItem In Application.ActiveExplorer.Selection
j = j + 1
For cnt = 1 To olItem.Attachments.Count
If Right(olItem.Attachments(1).FileName, 4) = "xlsx" Or Right(olItem.Attachments(1).FileName, 3) = "xls" Or Right(olItem.Attachments(1).FileName, 4) = "xlsm" Then
olItem.Attachments(cnt).SaveAsFile ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random & "\HWBs\" _
& Format(Now, "mmddyy") & " " & j & olItem.Attachments(cnt).DisplayName)
Set xlAtt = xlApp.Workbooks.Open("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random & "\HWBs\" _
& Format(Now, "mmddyy") & " " & j & olItem.Attachments(cnt).DisplayName)
xlAtt.Activate
If xlAtt.ActiveSheet.Range("A3").Value = "HWB" And xlAtt.ActiveSheet.Range("B3").Value = "Instruction (optional)" And xlAtt.ActiveSheet.Range("C3").Value = "Route (optional)" Then
LR = xlAtt.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
xlAtt.ActiveSheet.Range("A4:C4" & LR).Select
Selection.Copy
xlWB.Activate
xlWB.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial xlPasteValues
xlWB.ActiveSheet.Cells(1, 1).Activate
End If
xlApp.DisplayAlerts = False
xlAtt.Close SaveChanges:=False
Else
olItem.Categories = "Purple Category"
End If
Next
Next olItem
j = 4
LR = xlWB.ActiveSheet.UsedRange.Rows.Count
Do Until j > LR
If IsNumeric(Cells(j, 1)) = False Then
Cells(j, 1).EntireRow.Delete
LR = LR - 1
ElseIf Cells(j, 1).Value = "" Then
Cells(j, 1).EntireRow.Delete
LR = LR - 1
Else
j = j + 1
End If
Loop
xlWB.SaveAs ("C:\Users\dkirksey\Documents\SOF\HWB Files\" & Format(Now, "mmddyy") & random & "\" & Format(Now, "mmddyy") & " Complete HWB List")
Else
xlWB.Close
xlApp.DisplayAlerts = True
xlApp.Quit
Exit Sub
End If
End If
xlWB.Close
xlApp.DisplayAlerts = True
xlApp.Quit
MsgBox "Well played !"
End Sub
I'm a rookie with VBA so excuse any redundant or just plain idiotic coding methods you notice.
The subroutine works perfectly the first time it is run, just not the second. Please help.
Thank you.