I was hoping someone would be able to offer me some assistance please? My excel worksheet contains various columns, what I was hoping to do is simply just add another column at the end. So if my worksheet contains 20 columns of data i wish to add header to column U1, next time if my worksheet had 22 columns of data I wish to add header to V1 and so on
Now I have managed to get the next column letter however when I try to pass text into the header row I get an error of Object reference not set to an instance of an object on the following line
.Range(ColumnIndexToColumnLetter(lColumn + 1) & 1).Value = "TESTT"
Any help is greatly appreciated, many thanks
Dim xls As New Excel.Application
Dim xWorkbook As Excel.Workbook
Dim xWorksheet As Excel.Worksheet
Dim lColumn As Long = 0
xWorkbook = xls.Workbooks.Open("D:\Test.xlsx") 'File Location
xWorksheet = xWorkbook.Sheets(1)
xls.Visible = True
With xWorksheet
If xls.WorksheetFunction.CountA(.Columns) <> 0 Then
lColumn = .Columns.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=Excel.XlLookAt.xlPart, _
LookIn:=Excel.XlFindLookIn.xlFormulas, _
SearchOrder:=Excel.XlSearchOrder.xlByColumns, _
SearchDirection:=Excel.XlSearchDirection.xlPrevious, _
MatchCase:=False).Column
Else
lColumn = 1
End If
End With
With xWorksheet
.Range(ColumnIndexToColumnLetter(lColumn + 1) & 1).Value = "TESTT"
End With
Private Function ColumnIndexToColumnLetter(colIndex As Integer) As String
Dim div As Integer = colIndex
Dim colLetter As String = String.Empty
Dim modnum As Integer = 0
While div > 0
modnum = (div - 1) Mod 26
colLetter = Chr(65 + modnum) & colLetter
div = CInt((div - modnum) \ 26)
End While
Return colLetter
End Function
if you use option strict on you have to use cint for conversion, with this change your code works well
With xWorksheet
.Range(ColumnIndexToColumnLetter(CInt(lColumn + 1)) & 1).Value = "TESTT"
End With
Related
I need your help to build a macro that can extract the dates (which are in text format) from a string and report them in a different column - let's say to column K, would you be able to assist?
Below the database in text
Contract
OESX BLT 100 Feb22 Mar22 4200 vs S 5 FESX Mar22 #4080
OESX P 100 Mar22 3050 vs 6 FESX Mar22 #4080
OESX CDIA 100 Feb22 4300 Mar22 4400 vs B 3 FESX Mar22 #4090
OESX CNV 100 Dec23 4100 vs 100 FESX Mar22 #4100
OESX PBUT Feb22 3900 - 4000 - 4100
The length of the column of the database is not fixed, it changes every time.
The final goal would be to put the dates at the beginning of the contract and not in the middle.
I thank you in advance :)
CODE:
Sub Macro8()
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim row
Dim column
Dim value
fndList = Array("Dec22 ", "Dec23 ")
rplcList = Array("", "")
Set sht = Sheets("Data")
****For Each cell In Range("A2:A40")
If InStr(cell.Text, fndList) > 0 Then
cell.Offset(0, 1).value = fndList
End If
Next cell****
For x = LBound(fndList) To UBound(fndList)
sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next x
End Sub
Simple original answer:
Function RearrangeContract(ref As String)
Dim I As Integer
Dim N As Integer
Dim Res As String
Dim Con As String
Con = ref
For I = 1 To Len(ref) - 3
For N = 1 To 12
If Mid(ref, I, 3) = Format(DateSerial(2021, N, 15), "mmm") Then
Res = Res & Mid(ref, I, 5) & " "
Con = Replace(Con, Mid(ref, I, 6), "")
End If
Next N
Next I
RearrangeContract = Res & Con
End Function
Should spit out strings exactly as you requested.
[enter image description here][1]
Either use the function in your own code, or import the contract lines into excel and use =RearrangeContract() as a UDF
And here we have an absolute mess of code for such a small task, but I'm roughly 90% sure it will work perfectly.
FYI: I went the lazy route for the sorting, and borrowed a sorting sub from here: https://bettersolutions.com/vba/arrays/sorting-counting-sort.htm
Should rearrange, sort and filter duplicates
in the top function, you can change the date output format here:
"Res(i) = Format(Res(i), "mmmyy")"
Option Explicit
Option Base 0
Function RearrangeContractUnique(ref As String)
Dim i As Integer 'Character counter
Dim N As Integer 'Month counter
Dim Res() 'Result
Dim Con As String 'Contract - dates
Dim CNT As Integer 'Date found counter
Dim Temp
CNT = 0 'Counter to 0
Con = ref 'Store reference separately
For i = 1 To Len(ref) - 3 'Cycle through character in ref
For N = 1 To 12 'Test each month againt section of ref
If Mid(ref, i, 3) = Format(DateSerial(2021, N, 15), "mmm") Then
CNT = CNT + 1 'Increment counter
ReDim Preserve Res(1 To CNT) 'Resize array
'Debug.Print Mid(ref, i + 3, 2)
Res(CNT) = DateValue(DateSerial(20 & Mid(ref, i + 3, 2), N, 1))
Con = Replace(Con, Mid(ref, i, 6), "") 'Remove date found from ref
End If
Next N
Next i
'Debug.Print "PreSort"
'For i = 1 To CNT
'Debug.Print Res(i)
'Next i
Array_CountingSort Res
'Debug.Print "PostSort"
'For i = 1 To CNT
'Debug.Print Res(i)
'Next i
'Reformat for output
For i = 1 To CNT
Res(i) = Format(Res(i), "mmmyy")
Next i
'Yeah, just shovel more worksheetfunctions into it.
RearrangeContractUnique = Join(Application.WorksheetFunction.Transpose _
(WorksheetFunction.Unique(Application.WorksheetFunction. _
Transpose(Res())))) & " " & Con
End Function
Public Sub Array_CountingSort(ByRef vArrayName As Variant)
Dim vCounting() As Long
Dim lLower As Long
Dim lUpper As Long
Dim larraymin As Long
Dim larraymax As Long
Dim i As Long
Dim j As Long
Dim lnextpos As Long
larraymin = Helper_Minimum(vArrayName)
larraymax = Helper_Maximum(vArrayName)
lLower = LBound(vArrayName)
lUpper = UBound(vArrayName)
ReDim vCounting(larraymin To larraymax)
For i = lLower To lUpper
vCounting(vArrayName(i)) = vCounting(vArrayName(i)) + 1
Next i
lnextpos = lLower
For i = larraymin To larraymax
For j = 1 To vCounting(i)
vArrayName(lnextpos) = i
lnextpos = lnextpos + 1
Next j
Next i
End Sub
Public Function Helper_Maximum(ByVal vArrayName As Variant) As Long
Dim lmaxvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
lrowlower = LBound(vArrayName)
lrowupper = UBound(vArrayName)
lmaxvalue = vArrayName(lrowlower)
For i = lrowlower To lrowupper
If (vArrayName(i) > lmaxvalue) Then
lmaxvalue = vArrayName(i)
End If
Next i
Helper_Maximum = lmaxvalue
End Function
Public Function Helper_Minimum(ByVal vArrayName As Variant) As Long
Dim lminvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
lrowlower = LBound(vArrayName)
lrowupper = UBound(vArrayName)
lminvalue = vArrayName(lrowlower)
For i = lrowlower To lrowupper
If (vArrayName(i) < lminvalue) Then
lminvalue = vArrayName(i)
End If
Next i
Helper_Minimum = lminvalue
End Function
I am trying to copy data from one workbook to another based on the values contained in cells in the source workbook that matches the same values in the target workbook. For example, I have a table (Table1) that has four columns say, A1:D5. One of these columns (column A) contains account numbers that match similar account numbers located on another workbook (also in column A). I am trying to find a code that looks through the table (Table1) in the source workbook via the account number column, and if the account number matches the account number in the target workbook, copy and paste the cells on that row in specific locations to the target workbook. Is this possible?
I hope that makes sense. I have looked all over on how to structure such a code, and I was not able to find anything to start the process for this logic.
Any help will be very appreciative.
Thank you
Even if your question is about doing this in VBA, I'm just going to mention that what you are trying to do seems like it could also be done with Power Query.
That being said, if you were to use VBA for this, you would have to use the Match function to find where your rows match and then copy the data from the source to the destination table.
I've adapted the code I provided to this question to better serve your specific needs. One of the things I've done is to add an optional argument called DoOverwrite and set it to false. This will make sure that the information from one row won't be overwritten by another row later down the road.
Sub TableJoinTest()
'Those table columns will have to match for the 2 lines to be a match
Dim MandatoryHeaders() As Variant
MandatoryHeaders = Array("Account Number")
Dim SourceTableAnchor As Range
Set SourceTableAnchor = Workbooks("SourceWorkbook.xlsx").Sheets("Sheet1").Range("A1")
Dim TargetTableAnchor As Range
Set TargetTableAnchor = Workbooks("TargetWorkbook.xlsx").Sheets("Sheet1").Range("A1")
TableJoin _
SourceTableAnchor:=SourceTableAnchor, _
TargetTableAnchor:=TargetTableAnchor, _
MandatoryHeaders:=MandatoryHeaders, _
AddIfMissing:=False, _
IsLogging:=False, _
DoOverwrite:=False
End Sub
Sub TableJoin( _
SourceTableAnchor As Range, _
TargetTableAnchor As Range, _
MandatoryHeaders As Variant, _
Optional OtherHeaders As Variant, _
Optional AddIfMissing As Boolean = False, _
Optional IsLogging As Boolean = False, _
Optional DoOverwrite As Boolean = True)
'''''''''''''''''''''''''''''''''''''''
'Definitions
'''''''''''''''''''''''''''''''''''''''
Dim srng As Range, trng As Range
Set srng = SourceTableAnchor.CurrentRegion
Set trng = TargetTableAnchor.CurrentRegion
Dim sHeaders As Range, tHeaders As Range
Set sHeaders = srng.Rows(1)
Set tHeaders = trng.Rows(1)
'Store in Arrays
Dim sArray() As Variant 'prefix s is for Source
sArray = ExcludeRows(srng, 1).Value2
Dim tArray() As Variant 'prefix t is for Target
tArray = ExcludeRows(trng, 1).Value2
Dim sArrayHeader As Variant
sArrayHeader = sHeaders.Value2
Dim tArrayHeader As Variant
tArrayHeader = tHeaders.Value2
'Find Column correspondance
Dim sMandatoryHeadersColumn As Variant
ReDim sMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim tMandatoryHeadersColumn As Variant
ReDim tMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim k As Long
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), sArrayHeader, 0)
tMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), tArrayHeader, 0)
Next k
Dim sOtherHeadersColumn As Variant
ReDim sOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
Dim tOtherHeadersColumn As Variant
ReDim tOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
sOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), sArrayHeader, 0)
tOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), tArrayHeader, 0)
Next k
'Merge mandatory headers into one column (aka the helper column method)
Dim i As Long, j As Long
Dim sHelperColumn() As Variant
ReDim sHelperColumn(LBound(sArray, 1) To UBound(sArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sHelperColumn(i, 1) = sHelperColumn(i, 1) & sArray(i, sMandatoryHeadersColumn(j))
Next j
Next i
Dim tHelperColumn() As Variant
ReDim tHelperColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(tArray, 1) To UBound(tArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
tHelperColumn(i, 1) = tHelperColumn(i, 1) & tArray(i, tMandatoryHeadersColumn(j))
Next j
Next i
'Find all matches
Dim MatchList() As Variant
Dim LoggingColumn() As String
ReDim LoggingColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
ReDim MatchList(LBound(tArray, 1) To UBound(tArray, 1))
For j = LBound(tArray, 1) To UBound(tArray, 1)
If sHelperColumn(i, 1) = tHelperColumn(j, 1) Then
MatchList(j) = 1
End If
Next j
'Get the row number for the match
Dim MatchRow As Long
Select Case Application.Sum(MatchList)
Case Is > 1
'Need to do more matching
Dim MatchingScoresList() As Long
ReDim MatchingScoresList(1 To UBound(tArray, 1))
Dim m As Long
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
For m = LBound(tArray, 1) To UBound(tArray, 1)
If tArray(m, sOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k)) Then
MatchingScoresList(m) = MatchingScoresList(m) + 2 ^ (UBound(OtherHeaders) - k)
End If
Next m
Next k
'Get the max score position
Dim MyMax As Long
MyMax = Application.Max(MatchingScoresList)
If Application.Count(Application.Match(MatchingScoresList(), Array(MyMax), 0)) > 1 Then
MsgBox "Error: can't determine how to match row " & i & " in source table"
Exit Sub
Else
MatchRow = Application.Match(MyMax, MatchingScoresList, 0)
End If
Case Is = 1
MatchRow = Application.Match(1, MatchList, 0)
Case Else
Dim nArray() As Variant, Counter As Long
If AddIfMissing Then
MatchRow = 0
Counter = Counter + 1
ReDim nArray(1 To Counter, 1 To UBound(tArray, 2))
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
nArray(Counter, tMandatoryHeadersColumn(k)) = sArray(i, sMandatoryHeadersColumn(k))
Next k
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
nArray(Counter, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
Next k
Else
MsgBox "Error: Couldn't find a match for data row #" & i
Exit Sub
End If
End Select
'Logging and assigning values
If MatchRow > 0 Then
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
If tArray(MatchRow, tOtherHeadersColumn(k)) <> sArray(i, sOtherHeadersColumn(k)) Then
'Logging
If IsLogging And DoOverwrite Then LoggingColumn(MatchRow, 1) = LoggingColumn(MatchRow, 1) & _
IIf(LoggingColumn(MatchRow, 1) <> "", ", ", "") & _
tHeaders.Cells(1, tOtherHeadersColumn(k)) & " : " & _
tArray(MatchRow, tOtherHeadersColumn(k)) & _
" -> " & sArray(i, sOtherHeadersColumn(k))
'Assign new value
If DoOverwrite Or tArray(MatchRow, tOtherHeadersColumn(k)) = VbNullString Then
tArray(MatchRow, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
End If
End If
Next k
End If
Next i
'Write arrays to sheet
ExcludeRows(trng, 1).Value2 = tArray
With trng.Parent
If IsArrayInitialised(nArray) And AddIfMissing Then
.Cells(trng.Cells(1, 1).Row + trng.Rows.Count, trng.Cells(1, 1).Column).Resize(UBound(nArray, 1), UBound(nArray, 2)).Value2 = nArray
End If
If IsLogging Then
.Cells(trng.Cells(1, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count) = "Changes"
.Cells(trng.Cells(2, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count).Resize(UBound(LoggingColumn, 1), 1).Value2 = LoggingColumn
End If
End With
End Sub
And also add these functions inside your VBA project to as they are used in the procedure above.
Function IsArrayInitialised(ByRef A() As Variant) As Boolean
On Error Resume Next
IsArrayInitialised = IsNumeric(UBound(A))
On Error GoTo 0
End Function
Function ExcludeRows(MyRng As Range, StartRow As Long, Optional EndRow As Long = -1) As Range
'PURPOSE: Exclude one or more consecutives rows from an existing range
Dim Afterpart As Range, BeforePart As Range
If StartRow < 1 Or EndRow > MyRng.Rows.Count Then Set ExcludeRows = Nothing
If StartRow = 1 And EndRow = MyRng.Rows.Count Then Set ExcludeRows = Nothing
If EndRow = -1 Then EndRow = StartRow
If EndRow < MyRng.Rows.Count Then
With MyRng.Parent
Set Afterpart = .Range(MyRng.Cells(EndRow + 1, 1), MyRng.Cells(MyRng.Rows.Count, MyRng.Columns.Count))
End With
End If
If StartRow > 1 Then
With MyRng.Parent
Set BeforePart = .Range(MyRng.Cells(1, MyRng.Cells(1, 1).Column), MyRng.Cells(StartRow - 1, MyRng.Columns.Count))
End With
End If
Set ExcludeRows = Union2(True, BeforePart, Afterpart)
End Function
Public Function Union2(IgnoreEmptyRange As Boolean, ParamArray RangeArray() As Variant) As Range
'PURPOSE: Samae as Application.Union but allows some range object to be Empty
Dim V As Variant
Dim Rng As Range
For Each V In RangeArray
Do
If VarType(V) = vbEmpty Then Exit Do
Set Rng = V
If Not Union2 Is Nothing Then
Set Union2 = Union(Union2, Rng)
ElseIf Not Rng Is Nothing Then
Set Union2 = Rng
End If
Loop While False
Next
End Function
I have the following code that is intended to create a series of combo boxes on a worksheet. Since I cannot be in break mode when creating combo boxes I am struggling to find out what I am doing wrong.
Private Sub CreatePlayerSelectorComboBoxes()
Application.ScreenUpdating = True
Dim currStatusBarMgr As StatusBarManager
Set currStatusBarMgr = New StatusBarManager
currStatusBarMgr.MessagePrefix = "Creating Control: "
With MatchesTeamPlayersWS
.Range(.Cells(17, 1), .Cells(17, .UsedRange.Columns.Count)).ClearContents
Dim matchCounter As Long
For matchCounter = 1 To 6
Dim controlColumnMatch As Long
controlColumnMatch = ((matchCounter - 1) * 24)
Dim matchText As String
matchText = "M" & matchCounter
Dim teamCounter As Long
For teamCounter = 1 To 2
Dim controlColumnTeam As Long
controlColumnTeam = ((teamCounter - 1) * 12)
Dim teamText As String
Select Case teamCounter
Case Is = 1
teamText = "TmA"
Case Is = 2
teamText = "TmB"
End Select
Dim positionCounter As Long
For positionCounter = 1 To 4
Dim positionText As String
positionText = "P" & positionCounter
Dim controlText As String
controlText = matchText & teamText & positionText
Dim currDivAControlName As String
currDivAControlName = "DivA" & controlText
Dim currDivBControlName As String
currDivBControlName = "DivB" & controlText
Dim controlColumnPosition As Long
controlColumnPosition = 3 + ((positionCounter - 1) * 3)
Dim controlColumn As Long
controlColumn = controlColumnMatch + controlColumnTeam + controlColumnPosition
Dim controlCell As Range
Set controlCell = .Cells(17, controlColumn)
currStatusBarMgr.PostStatusBarUpdate (currDivAControlName)
Debug.Print currDivAControlName
Dim controlDivA As Variant
Set controlDivA = .OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
Link:=False, _
DisplayAsIcon:=False, _
Left:=controlCell.Left, _
Top:=controlCell.Top, _
Width:=140, _
Height:=24)
controlDivA.Name = currDivAControlName
currStatusBarMgr.PostStatusBarUpdate (currDivBControlName)
Debug.Print currDivBControlName
Dim controlDivB As Variant
Set controlDivB = .OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
Link:=False, _
DisplayAsIcon:=False, _
Left:=controlCell.Offset(0, 144).Left, _
Top:=controlCell.Offset(0, 144).Top, _
Width:=140, _
Height:=24)
controlDivB.Name = currDivBControlName
Next
Next
Next
End With
Application.ScreenUpdating = True
End Sub
If I comment out the parts that are intended to create the combo boxes the code runs. I have inspected the Set assignments and they appear to be syntactically correct. I have also made sure the names are unique.
I have let Excel run and run.. All I get is [running]... until I force-quit Excel.
I pass data into an array based on when column value <> column value. The array is formed fine, but when its about to move the array to a template, it gives me an object required error. This is brand new and was not erroring out before, what could fix this?
Getting error on this line:
Dest.Offset(j,a) = Data(i,k)
Rest of Code:
Option Explicit
Sub Main()
Dim Wb As Workbook
Dim Data, Last
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest As Range
Dim BASEPATH As String
Dim template As String
template = "M:\.xlsx"
BASEPATH = "M:\"
Set Wb = Workbooks.Open(Filename:=template)
Set Dest = Wb.Sheets("").Range("A3")
With ThisWorkbook.Sheets(1)
Data = .Range("BQ3", .Range("A" & Rows.Count).End(xlUp))
End With
Wb.Activate
For i = 1 To UBound(Data)
If Data(i, 10) <> Last Then
If i > 1 Then
Dest.Select
Wb.SaveCopyAs BASEPATH & _
ValidFileName(Last & "_YE_Planning_File.xlsx")
End If
With Wb.Sheets("")
.Rows(3 & ":" & .Rows.Count).Delete
End With
Last = Data(i, 10)
j = 0
End If
a = 0
For k = 1 To UBound(Data, 2)
Dest.Offset(j, a) = Data(i, k)
a = a + 1
Next
j = j + 1
Next
End Sub
Dest gets deleted.
Set Dest = Wb.Sheets("Pay for Performance Detail").Range("A3")
...
With Wb.Sheets("Pay for Performance Detail")
.Rows(3 & ":" & .Rows.Count).Delete <~ this includes A3, so `Dest` is deleted
End With
Move the Set Dest to after you do the deletion.
Better yet, don't Delete within a loop? (or maybe just ClearContents, as apparently you already had previously)
I'm building an master excel file that is designed to gather data from lots of other excel files that are stored in the business Dropbox files and place them in the 2nd sheet of the master file. I built a original version on my local computer and that worked perfectly (the path3 variable) but once I tried to convert it based on a changing file path (because each user will have a different path from their PC) I am getting the run time error. The formula defined by path2 is what I have been trying to use but even though the variable seems to be holding the right value (I tested it by having it write out the values) it doesn't seem to be able to move the data, throwing the above error and highlighting the "rngdest.Formula = Chr(61) & path2" line. I really don't have any idea what is causing this and I have spent several days trying different approaches but to no avail so any ideas, solutions or links to already solved (I have spent a long time searching but haven't found anything) would be very much appreciated.
I've included the whole of the code for completeness, I think I've removed most of the redundant code that I left in but there may be some still left. If you need any clarifications on the code please let me know. Thanks for any potential help
Private Sub CommandButton2_Click()
Dim counter As Integer
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim a As Integer
Dim z As Integer
Dim y As Integer
Dim p As Integer
Dim Names() As String
Dim Fix1() As String
Dim path3 As String
Dim path2 As String
Dim SheetName As String
Dim c As Range
Dim found As Range
Dim BookName As String
Dim var1 As String
Dim rngdest As Range
Dim rngsource As Range
Dim cell As String
Dim adjust As Integer
Dim adjust2 As Integer
Dim rngname As Range
Dim colNo As Integer
Dim fin As String
Dim fin2 As String
Dim fin3 As String
Dim comp As String
Dim teststring As String
Dim currentWb2 As Workbook
Set currentWb2 = ThisWorkbook
MsgBox "Excel will now update the sheet, please be patient as this can take a few minutes. You will be notified once it is complete"
ReDim Fix1(1 To 4)
Fix1(1) = "A-F"
Fix1(2) = "G-L"
Fix1(3) = "M-R"
Fix1(4) = "S-Z"
counter = 0
With ActiveSheet
i = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
ReDim Names(1 To i, 1 To 4)
With ActiveSheet
For k = 1 To 4
For a = 2 To i
Names(a, k) = Cells(a, k).Value
Next a
Next k
End With
SheetName = "Analysis"
BookName = "Outcomes Final.xlsm"
For p = 1 To 4
fin2 = Split(Cells(, p).Address, "$")(1)
With ActiveSheet
l = .Cells(.Rows.Count, fin2).End(xlUp).Row
End With
For z = 1 To l
counter = counter + 1
fin = Split(Cells(, counter).Address, "$")(1)
currentWb2.Sheets("Sheet2").Range("" & fin & "1") = Names(z, p)
For y = 1 To 34
adjust = y + 1
cell = "$B$" & y & ""
If z = 1 Then
Else
teststring = GetPath()
teststring = teststring & "\Clients\"
path3 = "'C:\Users\Lewis\Documents\Outcomes\Floating Support\Clients\" & Fix1(p) & "\" & Names(z, p) & "\[Outcomes Final.xlsm]Analysis'!" & cell & ""
path2 = teststring & Fix1(p) & "\" & Names(z, p) & "\Outcomes\[Outcomes Final.xlsm]Analysis'!" & cell & ""
End If
Set rngdest = currentWb2.Sheets("Sheet2").Range("" & fin & "" & adjust & "")
Set rngsource = Range("B" & y & "")
rngdest.Formula = Chr(61) & path2
Next y
Next z
Next p
currentWb2.Sheets("Sheet2").Columns(1).EntireColumn.Delete
currentWb2.Sheets("Sheet1").Range("A1:D35").Interior.ColorIndex = 0
For j = 1 To counter
fin3 = Split(Cells(, j).Address, "$")(1)
If currentWb2.Sheets("Sheet2").Range("" & fin3 & "35") = "1" Then
With currentWb2.Sheets("Sheet1").Range("A1:D35")
comp = currentWb2.Sheets("Sheet2").Range("" & fin3 & "1")
Set c = .Find(comp, LookIn:=xlValues)
If Not c Is Nothing Then
c.Interior.ColorIndex = 3
End If
End With
End If
Next j
MsgBox "The update is now complete, please click on sheet 2 to view the data. All clients in red have not been properly completed"
End Sub