VBA - Change the target Column to another Column - vba

Question

I have this code in one of the part of my script count the data from Column A if the data have duplicate value for 3 consecutive months it will be tag as "Selected" and "Updated"
Output would be like this:
Column A | Column B | Column C | Column D |
243899 | 1/20/2016 | | |
243899 | 2/10/2016 | | |
243899 | 3/15/2016 | Selected | Updated |
Note:
Column B is where the month value
Column C and D is where the data will be tag as "Selected" and "Updated"
I have 3 months of data
My problem is that i'm going to change all the target Column in the example above
Column A to Column T
Column B to Column BS
Column C and D to Column CH and CI
My code:
Public Sub Selection()
Dim file2 As Excel.Workbook
Dim Sheet2 As Worksheet, data(), i&
Dim myRangeColor As Variant, myRangeMonthValue
Dim MstrSht As Worksheet
Dim DataArr As Variant
Dim ColorArr As Variant
Dim MonthCol As Collection
Dim CloseToDate As Date
Dim MaxDate As Date
Dim c As Long
Set Sheet2 = Workbooks.Open(TextBox2.Text).Sheets(1)
'Load Data into Array
DataArr = Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
Find distinct colors
ColorArr = ReturnDistinct(Sheet2.Range("A2:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row))
Remove any values in the arrays third column
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
DataArr(i, 4) = ""
Next i
'Loop Each Color
For c = LBound(ColorArr) To UBound(ColorArr)
Set MonthCol = New Collection
MaxDate = 0
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
If DataArr(i, 1) = ColorArr(c) Then
'Load the colors months into a collection
On Error Resume Next
MonthCol.Add Month(DataArr(i, 2)), CStr(Month(DataArr(i, 2)))
On Error GoTo 0
'Find Max Date
If DataArr(i, 2) Then
MaxDate = Application.WorksheetFunction.Max(MaxDate, DataArr(i, 2))
End If
End If
Next i
'If the color were found in three or more seperate months then the row with date closest to CloseToDate gets flagged
If MonthCol.Count > 2 Then
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
If DataArr(i, 1) = ColorArr(c) And DataArr(i, 2) = MaxDate Then
DataArr(i, 3) = "Selected"
DataArr(i, 4) = "Updated"
End If
Next i
End If
Next c
'Print results to sheet
Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row) = DataArr
End Sub
Function ReturnDistinct(InpRng As Range) As Variant
Dim Cell As Range
Dim i As Integer
Dim DistCol As New Collection
Dim DistArr()
'Add all values to collection
For Each Cell In InpRng
On Error Resume Next
DistCol.Add Cell.Value, CStr(Cell.Value)
On Error GoTo 0
Next Cell
'Write collection to array
ReDim DistArr(1 To DistCol.Count)
For i = 1 To DistCol.Count Step 1
DistArr(i) = DistCol.Item(i)
Next i
ReturnDistinct = DistArr
End Function
I got my code here so im not really familiar to this code.. Is it possible to change the column in my script? I've done lots of trial and error on this one i can't seem to figure it out,. Any help, tips or suggestion i would gladly appreciate it!

Answer 1

In my previous comment, I had something in mind as follows. I tested this using columns A,B,C,D, but not using the more widely dispersed columns.
As a side note, I also had some trouble with your WorksheetFunction.Max call - I had to use CDate to get the comparison to work.
Public Sub Selection()
Dim file2 As Excel.Workbook
Dim Sheet2 As Worksheet, data(), i&
Dim myRangeColor As Variant, myRangeMonthValue
Dim MstrSht As Worksheet
Dim DataArr() As Variant
Dim TempArr1 As Variant, TempArr2 As Variant
Dim TempArr3 As Variant, TempArr4 As Variant
Dim ColorArr As Variant
Dim MonthCol As Collection
Dim CloseToDate As Date
Dim MaxDate As Date
Dim c As Long
Dim nRows As Long, nCols As Long
Dim iLoop As Long
' Set Sheet2 = Workbooks.Open(TextBox2.Text).Sheets(1)
Set Sheet2 = Sheets("Sheet2")
'Load Data into Array
' DataArr = Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
TempArr1 = Sheet2.Range("T2:T" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
TempArr2 = Sheet2.Range("BS2:BS" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
TempArr3 = Sheet2.Range("CH2:CH" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
TempArr4 = Sheet2.Range("CI2:CI" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
nRows = UBound(TempArr1)
nCols = 4
ReDim Preserve DataArr(1 To nRows, 1 To nCols)
For iLoop = 1 To nRows - 1
DataArr(iLoop, 1) = TempArr1(iLoop, 1)
DataArr(iLoop, 2) = TempArr2(iLoop, 1)
DataArr(iLoop, 3) = TempArr3(iLoop, 1)
DataArr(iLoop, 4) = TempArr4(iLoop, 1)
Next iLoop
'Find distinct colors
ColorArr = ReturnDistinct(Sheet2.Range("A2:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row))
'Remove any values in the arrays third column
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
DataArr(i, 3) = ""
Next i
'Loop Each Color
For c = LBound(ColorArr) To UBound(ColorArr)
Set MonthCol = New Collection
MaxDate = 0
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
If DataArr(i, 1) = ColorArr(c) Then
'Load the colors months into a collection
On Error Resume Next
MonthCol.Add Month(DataArr(i, 2)), CStr(Month(DataArr(i, 2)))
On Error GoTo 0
'Find Max Date
If DataArr(i, 2) > 0 Then
MaxDate = Application.WorksheetFunction.Max(CDate(MaxDate), CDate(DataArr(i, 2)))
End If
End If
Next i
'If the color were found in three or more seperate months then the row with date closest to CloseToDate gets flagged
If MonthCol.Count > 2 Then
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
If DataArr(i, 1) = ColorArr(c) And DataArr(i, 2) = MaxDate Then
DataArr(i, 3) = "Selected"
DataArr(i, 4) = "Updated"
End If
Next i
End If
Next c
'Print results to sheet
'Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row) = DataArr
For iLoop = 1 To nRows - 1
TempArr1(iLoop, 1) = DataArr(iLoop, 1)
TempArr2(iLoop, 1) = DataArr(iLoop, 2)
TempArr3(iLoop, 1) = DataArr(iLoop, 3)
TempArr4(iLoop, 1) = DataArr(iLoop, 4)
Next iLoop
Sheet2.Range("T2:" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row).Value2 = TempArr1
Sheet2.Range("BS2:BS" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row).Value2 = TempArr2
Sheet2.Range("CH2:CH" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row).Value2 = TempArr3
Sheet2.Range("CI2:CI" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row).Value2 = TempArr3
End Sub