VBA - Başka Sütun hedef Sütun değiştirme

Question

Veri Seçilmiş "gibi etiketi olacaktır 3 ay üst üste yinelenen değer varsa benim senaryonun parçası birinde bu kod Sütun A veri saymak zorunda "ve "Güncelleme"

Çıktı böyle olacağını:

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

Not:

• Sütun B olduğu aylık değeri
• "Seçilmiş" ve
• Verilerin 3 ay içinde "Güncelleme" gibi veri etiketi olacak burada Cı ve D olan sütun

sorunum beniçin

1. Column A yukarıdaki örnekte tüm hedef sütun değiştirmek için gidiyorum olmasıdır
2. Column BColumn BS
3. Column C ve DColumn CH ve CI

My kodu:

Ben bu koda böylece im gerçekten aşina olmayan benim kodu var

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 

.. bunu mı komutumdaki sütunu değiştirmek mümkün mü? Bu konuda bir sürü deneme ve hata yaptım, bunu anlayamıyorum. Herhangi bir yardım, ipucu veya öneri memnuniyetle takdir ediyorum!

Answer 1

Önceki yorumumda aklımda bir şey vardı. Bunu A, B, C, D sütunlarını kullanarak test ettim, ancak daha yaygın olarak dağılmış sütunları kullanmamaya çalıştım.

Bir yan not olarak, ben de WorksheetFunction.Max çağrısı ile bazı sorun vardı - Ben karşılaştırma karşılaştırmak için CDate kullanmak zorunda kaldı. Ve Sheet2.Cells (: hattı `DataArr = Sheet2.Range ("D A2" -

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