VBA - Change the target Column to another Column

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!

The code you are starting with takes advantage of the fact the results are being posted in columns that are adjacent to each other - the line DataArr = Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row) will need to be changed to get data into the array from your new columns, perhaps with a Loop. The line Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row) = DataArr will need to be changed to write the data from the array into your new columns, again perhaps with a Loop. — OldUgly
– OldUgly, Commented Apr 12, 2016 at 3:13
@OldUgly thanks, i did tried to change that line many times it's not working is it really possible to change this columns? it's feels like is in default — 7A65726F
– 7A65726F, Commented Apr 12, 2016 at 3:20

OldUgly · Accepted Answer · 2016-04-12 05:12:05Z

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

there's no data from column CH, CI, b-but thank you so much for your effort! T.T
i finally get how it works, i've been working on this for the last five days, thank you so much your a life saver!

Collectives™ on Stack Overflow

VBA - Change the target Column to another Column

1 Answer 1

2 Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

2 Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related