The following code should be part of a parking management tool. It is basically nothing more than a conditional formatting of parking spaces in the form of defined ranges in a sheet "GF" based on an associated status defined as a string in a list object in a sheet "GF List".
Unlike the example below, the code is to be applied later to several hundred parking spaces with eight possible formattings, so I want to solve the whole thing using a VBA procedure instead of the standard conditional formatting.
The code fails because I can't dynamically retrieve the "CurrentLot" as a Range to then format it in the IfThenElse procedure.
I hope that you guys can help me. Thanks a lot.
Sub No_01_to_05a()
Dim gfList As Worksheet
Dim gfPlan As Worksheet
Dim status As String
Dim CurrentLot As Range
Dim i As Integer
Dim No As String
Set gfList = ThisWorkbook.Worksheets("GF List")
Set gfPlan = ThisWorkbook.Worksheets("GF")
'Parking lots that are defined manually here
Dim LotNo1 As Range
Set LotNo1 = gfPlan.Range("B2", "C2")
Dim LotNo2 As Range
Set LotNo2 = gfPlan.Range("D2", "E2")
Dim LotNo3 As Range
Set LotNo3 = gfPlan.Range("F2", "G2")
Dim LotNo4 As Range
Set LotNo4 = gfPlan.Range("H2", "I2")
Dim LotNo5 As Range
Set LotNo5 = gfPlan.Range("J2", "K2")
Dim LotNo5a As Range
Set LotNo5a = gfPlan.Range("M2", "M3")
'ForNext procedure
For i = 4 To gfList.Range("E" & Application.Rows.Count).End(xlUp).Row
status = gfList.Range("E" & i).Value
No = gfList.Range("B" & i).Value
CurrentLot = "LotNo" & No 'Line that does not seem to work
If status = "Vacant" Then
CurrentLot.Interior.Color = RGB(255, 255, 0)
CurrentLot.Font.Color = RGB(0, 0, 0)
ElseIf status = "Let" Then
CurrentLot.Interior.Color = RGB(146, 208, 80)
CurrentLot.Font.Color = RGB(0, 0, 0)
ElseIf status = "Reserved" Then
CurrentLot.Interior.Color = RGB(0, 176, 240)
CurrentLot.Font.Color = RGB(0, 0, 0)
Else
CurrentLot.Interior.Color = RGB(255, 255, 255)
CurrentLot.Font.Color = RGB(0, 0, 0)
End If
Next i
End Sub
VBA does not have this feature to evaluate expressions inside the language, so since the lot No is not always a number, you could use a Dictionary to save the lots with the No as keys
Sub No_01_to_05a()
Dim gfList As Worksheet
Dim gfPlan As Worksheet
Dim status As String
Dim CurrentLot As Range
Dim i As Integer
Dim No As String
Dim dictLot As Object
Set dictLot = CreateObject("Scripting.Dictionary")
Set gfList = ThisWorkbook.Worksheets("GF List")
Set gfPlan = ThisWorkbook.Worksheets("GF")
dictLot "1", gfPlan.Range("B2", "C2")
dictLot "2", gfPlan.Range("D2", "E2")
dictLot "3", gfPlan.Range("F2", "G2")
dictLot "4", gfPlan.Range("H2", "I2")
dictLot "5", gfPlan.Range("J2", "K2")
dictLot "5a", gfPlan.Range("M2", "M3")
'ForNext procedure
For i = 4 To gfList.Range("E" & Application.Rows.Count).End(xlUp).row
status = gfList.Range("E" & i).Value
No = gfList.Range("B" & i).Value
If Not dictLot.Exists(No) Then
MsgBox "Lot: " & No & " does not exists.", vbInformation ' Show a message when the lot does not exists
Exit For
End If
Set CurrentLot = dictLot(No) ' Retrieve the lot using the No as key in the dictionary
If status = "Vacant" Then
CurrentLot.Interior.Color = RGB(255, 255, 0)
CurrentLot.Font.Color = RGB(0, 0, 0)
ElseIf status = "Let" Then
CurrentLot.Interior.Color = RGB(146, 208, 80)
CurrentLot.Font.Color = RGB(0, 0, 0)
ElseIf status = "Reserved" Then
CurrentLot.Interior.Color = RGB(0, 176, 240)
CurrentLot.Font.Color = RGB(0, 0, 0)
Else
CurrentLot.Interior.Color = RGB(255, 255, 255)
CurrentLot.Font.Color = RGB(0, 0, 0)
End If
Next i
End Sub
Here more info about Dictionary
You cannot assign a variable resp. object to another variable/object just by assigning a string to that variable which is just the same as the name of the variable. That's what you seem to want to do with CurrentLot = "LotNo" & No
You have to do use a Select Case statement to achieve that
Option Explicit
Sub No_01_to_05a()
Dim gfList As Worksheet
Set gfList = ThisWorkbook.Worksheets("GF List")
Dim status As String
Dim CurrentLot As Range
Dim i As Integer
Dim No As String
'ForNext procedure
For i = 4 To gfList.Range("E" & Application.Rows.Count).End(xlUp).Row
status = gfList.Range("E" & i).Value
No = gfList.Range("B" & i).Value
'CurrentLot = "LotNo" & No <= You cannot assign a string to a range
Set CurrentLot = getLot(No)
If status = "Vacant" Then
CurrentLot.Interior.Color = RGB(255, 255, 0)
CurrentLot.Font.Color = RGB(0, 0, 0)
ElseIf status = "Let" Then
CurrentLot.Interior.Color = RGB(146, 208, 80)
CurrentLot.Font.Color = RGB(0, 0, 0)
ElseIf status = "Reserved" Then
CurrentLot.Interior.Color = RGB(0, 176, 240)
CurrentLot.Font.Color = RGB(0, 0, 0)
Else
CurrentLot.Interior.Color = RGB(255, 255, 255)
CurrentLot.Font.Color = RGB(0, 0, 0)
End If
Next i
End Sub
Function getLot(ByVal No As Long) As Range
Dim gfPlan As Worksheet
Set gfPlan = ThisWorkbook.Worksheets("GF")
'Parking lots that are defined manually here
Dim LotNo1 As Range
Set LotNo1 = gfPlan.Range("B2", "C2")
Dim LotNo2 As Range
Set LotNo2 = gfPlan.Range("D2", "E2")
Dim LotNo3 As Range
Set LotNo3 = gfPlan.Range("F2", "G2")
Dim LotNo4 As Range
Set LotNo4 = gfPlan.Range("H2", "I2")
Dim LotNo5 As Range
Set LotNo5 = gfPlan.Range("J2", "K2")
Dim LotNo5a As Range
Set LotNo5a = gfPlan.Range("M2", "M3")
Select Case No
Case 1
Set getLot = LotNo1
Case 2
Set getLot = LotNo2
Case 3
Set getLot = LotNo3
Case 4
Set getLot = LotNo4
Case 5
Set getLot = LotNo5
Case Else
'
End Select
End Function
Further reading on Select Case statement.
Solved using the Dictionary Function:
Sub No_01_to_05a()
Dim gfList As Worksheet
Dim gfPlan As Worksheet
Dim status As String
Dim CurrentLot As Range
Dim i As Integer
Dim No As String
Dim dictLot As New Dictionary
Set gfList = ThisWorkbook.Worksheets("GF List")
Set gfPlan = ThisWorkbook.Worksheets("GF")
Dim dictLot As New Dictionary
dictLot.Add "1", gfPlan.Range("B2", "C2")
dictLot.Add "2", gfPlan.Range("D2", "E2")
dictLot.Add "3", gfPlan.Range("F2", "G2")
dictLot.Add "4", gfPlan.Range("H2", "I2")
dictLot.Add "5", gfPlan.Range("J2", "K2")
dictLot.Add "5a", gfPlan.Range("M2", "M3")
'ForNext procedure
For i = 4 To gfList.Range("E" & Application.Rows.Count).End(xlUp).Row
status = gfList.Range("E" & i).Value
No = gfList.Range("B" & i).Value
Set CurrentLot = dictLot(No) ' Retrieve the lot using the No as key in the dictionary
If status = "Vacant" Then
CurrentLot.Interior.Color = RGB(255, 255, 0)
CurrentLot.Font.Color = RGB(0, 0, 0)
ElseIf status = "Let" Then
CurrentLot.Interior.Color = RGB(146, 208, 80)
CurrentLot.Font.Color = RGB(0, 0, 0)
ElseIf status = "Reserved" Then
CurrentLot.Interior.Color = RGB(0, 176, 240)
CurrentLot.Font.Color = RGB(0, 0, 0)
Else
CurrentLot.Interior.Color = RGB(255, 255, 255)
CurrentLot.Font.Color = RGB(0, 0, 0)
End If
Next i
End Sub
Related
Hi i am making a organisational hierarchy chart and i want to have a textbox below each nodes. What i did until now was to retrieve the data and plot out the hierarchy. But how do i add textbox under them? I have to add 2 textboxes below each nodes. Any help will be appreciated!
Code:
Option Explicit
Sub OrgChart()
Dim ogSALayout As SmartArtLayout
Dim QNodes As SmartArtNodes
Dim QNode As SmartArtNode
Dim ogShp As Shape
Dim shp As Shape
Dim t As Long
Dim i As Long
Dim r As Long
For Each shp In ActiveSheet.Shapes
If shp.Type = msoSmartArt Then: shp.Delete
Next shp
Set ogSALayout = Application.SmartArtLayouts( _
"urn:microsoft.com/office/officeart/2009/3/layout/HorizontalOrganizationChart" _
)
Set ogShp = ActiveSheet.Shapes.AddSmartArt(ogSALayout, 630, 36, 1000, 1000)
Set QNodes = ogShp.SmartArt.AllNodes
t = QNodes.Count
For i = 2 To t: ogShp.SmartArt.Nodes(1).Delete: Next i
Set QNode = QNodes(1)
If Range("D1").Value = "CONFIRM" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Range("D1").Value = "PENDING" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(128, 128, 128)
ElseIf Range("D1").Value = "SUSPECTED" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(255, 255, 0)
ElseIf Range("D1").Value = "NO" Then
QNode.Shapes.Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
With QNode.TextFrame2.TextRange
.Text = Range("B1").Value
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
.Font.Bold = True
End With
With QNode.Shapes.AddTextbox(msoTextOrientationHorizontal, _
100, 100, 200, 50) _
.TextFrame.Characters.Text = "Test Box"
End With
r = 1
Call AddChildren(QNode, r)
ogShp.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
End Sub
Sub AddChildren(ByVal QParent As SmartArtNode, ByVal r As Long)
Dim QChild As SmartArtNode
Dim Level As Long
Dim s As Long
Const MyCol As String = "C"
Level = Range(MyCol & r).Value
s = r + 1
Do While Range(MyCol & s).Value > Level
If Range(MyCol & s).Value = Level + 1 Then
Set QChild = QParent.AddNode(msoSmartArtNodeBelow)
If Range("D" & s).Value = "CONFIRM" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Range("D" & s).Value = "PENDING" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(128, 128, 128)
ElseIf Range("D" & s).Value = "SUSPECTED" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(255, 255, 0)
ElseIf Range("D" & s).Value = "NO" Then
QChild.Shapes.Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
With QChild.TextFrame2.TextRange
.Text = Range("B" & s).Value
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
End With
Call AddChildren(QChild, s)
End If
s = s + 1
Loop
End Sub
This is what it looks like now:
Edit: Added screenshot of data layout.
Adding a textbox under a node would mean that you would have to move the node up to make room for the textbox. As far as I know, it's not possible to move the nodes using VBA.
As a workaround, you could create another node under each node and format it as a textbox.
The outcome would look something like this:
To do this, I would first remove this from OrgChart
With QNode.Shapes.AddTextbox(msoTextOrientationHorizontal, _
100, 100, 200, 50) _
.TextFrame.Characters.Text = "Test Box"
End With
And replace it with:
Dim PseudoTxtBox As SmartArtNode
Set PseudoTxtBox = QNode.AddNode(msoSmartArtNodeAfter) 'Pseudo text box
'Add some text to the textbox
With PseudoTxtBox.TextFrame2.TextRange
.Text = "Some Text"
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
End With
'Make the textbox background transparent
PseudoTxtBox.Shapes.Fill.Transparency = 1
Then I would insert the following code right after adding the node in AddChildren :
Dim PseudoTxtBox As SmartArtNode
Set PseudoTxtBox = QChild.AddNode(msoSmartArtNodeAfter) 'Pseudo text box
'Add some text to the textbox
With PseudoTxtBox.TextFrame2.TextRange
.Text = "Some Text"
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 12
End With
'Make the textbox background transparent
PseudoTxtBox.Shapes.Fill.Transparency = 1
'Get the parent shape
Dim mshp As Shape
Dim tempObject As Object
Set tempObject = QChild.Parent
Do While TypeName(tempObject) <> "Shape"
Set tempObject = tempObject.Parent
Loop
Set mshp = tempObject
'Set the corresponding connector (line) to be transparent.
mshp.GroupItems(Level).Line.Transparency = 1
I currently have a loop that checks if cells in a range fall between two dates. My loop currently creates a new shape for every cell that is between the given date ranges.
I want my loop to take the first given date range and output the sum of all cells within the my range that fall between the date range. I also want the loop to title the cell above the shape with the month it searched.
My date ranges are startDate and endDate
Code
Sub foo()
Dim oval As Shape
Dim rCell As Range
Dim rng As Range
Dim h As Integer
Dim w As Integer
Dim x As Long
Dim shp As Object
Dim counter As Long
Dim startDate As Date, endDate As Date
Set rng = Sheet1.Range("A1:B6")
h = 495
startDate = "01/01/2019"
endDate = "03/10/2019"
For Each rCell In rng
If IsDate(rCell.Value) Then
If rCell.Value >= startDate And rCell.Value <= endDate Then
counter = counter + 1
Set oval = ActiveSheet.Shapes.AddShape(msoShapeOval, h + 70 * (counter - 1), w + 125, 60, 65)
With oval
.Line.Visible = True
.Line.Weight = 2
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = RGB(0, 0, 0)
.TextFrame.Characters.Caption = rCell.Value
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.Characters.Font.Size = 12
.TextFrame.Characters.Font.Bold = True
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
End With
End If
End If
Next rCell
End Sub
Desired Output
Current Output
So you want to basically sum by a month, and to do that an array is probably the easiest thing to do. I'll assume it's only one year at time, but you could lookup Redim Preserver to make that change.
This is incrementing every value in the set range and adding it to the array corresponging to the month number.
Sub BoOm()
Dim YourSTuff(1 To 12, 0 To 0) As Long, aCell As Range, YourRNG As Range, startDate As Date, endDate As Date
Set YourRNG = Range("A1:B99")
startDate = "01/01/2019"
endDate = "03/10/2019"
For Each aCell In YourRNG.Cells
If IsDate(aCell.Value) Then
If aCell.Value >= startDate And aCell.Value <= endDate Then
YourSTuff(Month(aCell), 0) = YourSTuff(Month(aCell), 0) + 1
End If
End If
Next aCell
'when you're done.
Dim i As Long, c As Long
c = 1
For i = LBound(YourSTuff) To UBound(YourSTuff)
If YourSTuff(i, 0) > 0 Then
Set Oval = ActiveSheet.Shapes.AddShape(msoShapeOval, h + 70 * (c), w + 125, 60, 65)
c = c + 1
With Oval
'not sure how to format as you want
.Line.Visible = True
.Line.Weight = 2
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = RGB(0, 0, 0)
.TextFrame.Characters.Caption = Choose(i, "January", "February", "March", "April", "May", "June", "" & _
"July", "August", "September", "October", "November", "December") & Chr(10) & YourSTuff(i, 0)
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.Characters.Font.Size = 12
.TextFrame.Characters.Font.Bold = True
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
End With
End If
Next i
End Sub
I have several freeforms that I formed to a group. Now I want the Shape Fill and Shape Outline color of all freeforms of the group to change based on a cell value. That I was able to do with the code below. However the outer Shape Outline of the whole group should always stay black, what doesn't owrk with my code. I found some code on the internet that might go in this direction but I don't really understand it and it doesn't work in my file (seems to work only for rectangle shapes). Any help is much appreciated.
I found a macro on the internet but this seems to be only for groups with a rectangle from:
Code I got so far:
Sub Region_Portugal()
Dim shp As Shape
Dim rg As Range
Dim rg1 As Range
Dim rg2 As Range
Dim rg3 As Range
Set rg = Sheet9.Range("N37")
Set rg1 = Sheet9.Range("I9")
Set rg2 = Sheet9.Range("I10")
Set rg3 = Sheet9.Range("I11")
If rg <= rg1 Then
For Each shp In Sheet7.Shapes.Range(Array("Group 83"))
shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
shp.Line.ForeColor.RGB = RGB(255, 0, 0)
Next
ElseIf rg > rg1 And rg <= rg2 Then
For Each shp In Sheet7.Shapes.Range(Array("Group 83"))
shp.Fill.ForeColor.RGB = RGB(255, 165, 0)
shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 165, 0)
shp.Line.ForeColor.RGB = RGB(255, 165, 0)
Next
ElseIf rg > rg2 And rg <= rg3 Then
For Each shp In Sheet7.Shapes.Range(Array("Group 83"))
shp.Fill.ForeColor.RGB = RGB(255, 255, 0)
shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 0)
shp.Line.ForeColor.RGB = RGB(255, 255, 0)
Next
ElseIf rg > rg3 Then
For Each shp In Sheet7.Shapes.Range(Array("Group 83"))
shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 255, 0)
shp.Line.ForeColor.RGB = RGB(0, 255, 0)
Next
Else
For Each shp In Sheet7.Shapes.Range(Array("Group 83"))
shp.Fill.ForeColor.RGB = RGB(192, 192, 192)
shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(192, 192, 192)
shp.Line.ForeColor.RGB = RGB(192, 192, 192)
Next
End If
End Sub
Code I found on the internet:
Sub AddBorderToGroup()
Dim oShRng As ShapeRange
Dim oSl As Slide
Set oShRng = ActiveWindow.Selection.ShapeRange
Set oSl = oShRng.Parent
With oSl
With .Shapes.AddShape(msoShapeRectangle, _
oShRng.Left, oShRng.Top, oShRng.Width, oShRng.Height)
.Fill.Visible = False
.Line.Visible = True
.Line.Weight = 2 ' points
' etc for other line properties
End With
End With
End Sub
The final result would be a map of the Iberian Peninsula where the different regions of Spain and Portugal are colored differently based on cell values. The map I use as template consists of freeforms for each provice. So I need to group together different provinces to get bigger regions. the regions should have a black boarder so that you can differentiate them in case there are several regions next to each other that have the same color.
While trying to check whether a value is present in an array If Not IsError(Application.Match(arrString, RegM, 0)) Then...
But for some reason it doesn't work.
I also tried the following but without success Application.WorksheetFunction.CountIf(DirArray2, RegM)
When I check the values in a msgbox everything seems ok, but still it doesn't work (below msgbox shows for example "DMM | DMM|TEST"
MsgBox RegM & " | " & Application.WorksheetFunction.CountIf(DirArray2, RegM)
I quoted the whole function because perhaps you find something in the code that causes the problem
Sub mk_RegExp()
If Sheets("MISC").Range("C62") = True Then
Dim objRegex As Object
Dim RegMC As Object
Dim RegM As Object
Dim item As Variant
Dim DirArray As Variant
Dim DirArray2 As Variant
Dim DirArr As Variant
Dim test As Variant
'------------------------------------------------------------------------------------------------
Sheets("LI").Range("C12:DJ42").Font.Color = vbBlack
'------------------------------------------------------------------------------------------------
arr = Sheets("MISC").Range("R4:R145").Value
LastRow = Sheets("MISC").Cells(Rows.Count, "L").End(xlUp).Row
DirArray = Join(Application.Transpose(Sheets("MISC").Range("L4:L" & LastRow).Value), "|")
LastRow2 = Sheets("MISC").Cells(Rows.Count, "M").End(xlUp).Row
DirArray2 = Join(Application.Transpose(Sheets("MISC").Range("M4:M" & LastRow2).Value), "|")
arrString = Join(Application.Transpose(Sheets("MISC").Range("M4:M" & LastRow2).Value), ",")
DirArr = DirArray & "|" & DirArray2
'------------------------------------------------------------------------------------------------
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = DirArr
For Each item In arr
If .test(Range(item).Value) Then
Set RegMC = .Execute(Range(item).Value)
For Each RegM In RegMC
If Not IsError(Application.Match(arrString, RegM, 0)) Then
'MsgBox RegM & " | " & Application.WorksheetFunction.CountIf(DirArray2, RegM)
Range(item).Characters(RegM.FirstIndex + 1, RegM.Length).Font.Color = RGB(0, 176, 80)
ElseIf RegM = "COL" Or RegM = "CRT" Then
Range(item).Characters(RegM.FirstIndex + 1, RegM.Length).Font.Color = RGB(0, 176, 240)
Else
Range(item).Characters(RegM.FirstIndex + 1, RegM.Length).Font.Color = RGB(247, 150, 70)
End If
Next
End If
Next item
End With
Else
Sheets("LI").Range("C12:DJ42").Font.Color = vbBlack
End If
End Sub
In addition to my comment
Sub test_array()
Dim a() As Variant
a = Application.Transpose(Range("a1:a5"))
Debug.Print Join(a, "|")
Debug.Print Application.WorksheetFunction.Match("Test 2", a, 0)
Debug.Print Application.WorksheetFunction.Match("Test 2", Join(a, "|"), 0)
End Sub
The second line errors, the first is ok.
I've been trying to make the below code work, and it did yesterday evening, but somehow this morning upon opening Excel it stopped functioning. Essentially, I'm using a vlookup macro to important data from various workbooks, and the workbook names depend on the respective "title" of that row. First, I check with an if statement whether the file actually exists; if it doesn't, I want to highlight the title cell red, and move onto the next row to carry out the same check. If the file does exist, I want to populate the row with the appropriate data and highlight the title cell with white colour.
Below my code - I'd really appreciate if you could take a look and help me out!
Public Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo NextStep
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
NextStep:
On Error GoTo 0
End Function
Private Sub CommandButton1_Click()
Dim wsi As Worksheet
Dim wse As Worksheet
Dim j As Integer
Dim i As Integer
Set wsi = ThisWorkbook.Sheets("Income")
Set wse = ThisWorkbook.Sheets("Expense")
j = 3
For i = 1 To 46
If FileFolderExists(wsi.Cells(5, i + 2).Value & ".xlsx") Then
wsi.Range(wsi.Cells(6, j), wsi.Cells(51, j)).Formula = "=VLOOKUP(index($B$6:$AV$51,row()-5,1),'[" & wsi.Cells(5, i + 2).Value & ".xlsx]Sheet1'!$A$1:$E$70,4,FALSE)"
Sheets("Mark-Up Table").Cells(i + 5, 2).Interior.Color = RGB(255, 255, 255)
Sheets("Mark-Up Table").Cells(5, i + 2).Interior.Color = RGB(255, 255, 255)
Else
Sheets("Mark-Up Table").Cells(i + 5, 2).Interior.Color = RGB(255, 0, 0)
Sheets("Mark-Up Table").Cells(5, i + 2).Interior.Color = RGB(255, 0, 0)
End If
If FileFolderExists(wse.Cells(5, i + 2).Value & ".xlsx") Then
wse.Range(wse.Cells(6, j), wse.Cells(51, j)).Formula = "=VLOOKUP(index($B$6:$AV$51,row()-5,1),'[" & wse.Cells(5, i + 2).Value & ".xlsx]Sheet2'!$A$1:$E$70,5,FALSE)"
Else
'do nothing
End If
j = j + 1
Next i
End Sub
I have managed to solve the issue. For people who might be facing similar problems, please see below:
Private Sub CommandButton1_Click()
Dim strPath As String
Dim wsi As Worksheet
Dim wse As Worksheet
Dim j As Integer
Dim i As Integer
Set wsi = ThisWorkbook.Sheets("Income")
Set wse = ThisWorkbook.Sheets("Expense")
strPath = Sheets("Mark-Up Table").Range("H3").Value
j = 3
For i = 1 To 46
If Dir(strPath & wsi.Cells(i + 5, 2).Value & ".xlsx") = vbNullString Then
Sheets("Mark-Up Table").Cells(i + 5, 2).Interior.Color = RGB(255, 0, 0)
Sheets("Mark-Up Table").Cells(5, i + 2).Interior.Color = RGB(255, 0, 0)
Else
wsi.Range(wsi.Cells(3 + j, 3), wsi.Cells(3 + j, 48)).Formula = "=VLOOKUP(index($C$5:$AV$51,1,column()-2),'[" & wsi.Cells(i + 5, 2).Value & ".xlsx]Sheet1'!$A$1:$E$70,4,FALSE)"
Sheets("Mark-Up Table").Cells(i + 5, 2).Interior.Color = RGB(255, 255, 255)
Sheets("Mark-Up Table").Cells(5, i + 2).Interior.Color = RGB(255, 255, 255)
End If
If Dir(strPath & wse.Cells(5, i + 2).Value & ".xlsx") = vbNullString Then
'do nothing
Else
wse.Range(wse.Cells(6, j), wse.Cells(51, j)).Formula = "=abs(VLOOKUP(index($B$6:$AV$51,row()-5,1),'[" & wse.Cells(5, i + 2).Value & ".xlsx]Sheet1'!$A$1:$E$70,5,FALSE))"
End If
j = j + 1
Next i
End Sub