VBA - Ändern Sie die Zielspalte in eine andere Spalte

Question

Ich habe diesen Code in einem der Teil meines Skripts zählen die Daten von Spalte A Wenn die Daten doppelte Wert für 3 aufeinander folgende Monate haben wird es Tag als "Ausgewählt "und "aktualisiert"

Ausgang würde so aussehen:

Column A | Column B | Column C | Column D | 
243899 | 1/20/2016 |   |   | 
243899 | 2/10/2016 |   |   | 
243899 | 3/15/2016 | Selected | Updated | 

Hinweis:

• Spalte B ist, wo der Wert für den Monat
• Spalte C und D ist, wo die Daten-Tag wird als „Ausgewählt“ und „aktualisiert“
• Ich habe 3 Monate Daten

oben

1. Column A bis

   Mein Problem ist, dass ich werde alle Spalte das Ziel im Beispiel ändern

2. Column B-Column BS
3. Column C und D-Column CH und CI

Mein 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 

ich hier meinen Code wurde so im nicht wirklich vertraut .. zu diesem Code ist es möglich, die Spalte in meinem Skript zu ändern? Ich habe viel Versuch und Irrtum auf diesem einen gemacht, ich kann nicht scheinen, es herauszufinden. Jede Hilfe, Tipps oder Anregungen würde ich gerne zu schätzen wissen!

Answer 1

In meinem vorherigen Kommentar hatte ich etwas im Sinn wie folgt. Ich testete dies mit den Spalten A, B, C, D, aber nicht mit den weiter verteilten Säulen.

Als eine Nebenbemerkung hatte ich auch einige Probleme mit Ihrem Aufruf WorksheetFunction.Max - ich musste CDate verwenden, um den Vergleich zu funktionieren.

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