Автозаполнение ячеек с условием - PullRequest
Новая
       19

Автозаполнение ячеек с условием

0 голосов
/ 25 марта 2011

Я застрял с кодом.Я признаю, что я не опытный программист, но, несмотря на то, что я потратил немало времени на поиск в интернете, я не могу создать код.Ситуация такова.

У меня в листе 2 столбцы (А и С).В столбце AI есть несколько идентификационных номеров, и всегда есть несколько строк с одинаковым номером (например, ID 12345 находится в строках с 6 по 15).Каждому идентификационному номеру соответствует соответствующая дата в столбце C.

. В SheetA в ячейке C4 я выбираю идентификационный номер и хочу создать код, который автоматически заполняет столбец F (sheetA), начиная со строки 12 свсе доступные даты, соответствующие идентификатору в SheetB.

Может кто-нибудь помочь мне, пожалуйста?Спасибо!

Ответы [ 2 ]

0 голосов
/ 25 марта 2011

попробуйте это: 

Dim rgIDsAndDates As Range: Set rgIDsAndDates = Range("name")
Dim DATEs As Collection ' to collect date values for a given ID
Dim IDs   As Collection ' to collect all the DATEs collections for all IDs

' step 1: loop to create (initially empty) collections for each unique ID
Set IDs = New Collection
Dim rgRow As Range
For Each rgRow In rgIDsAndDates.Rows
    Set DATEs = New Collection
    On Error Resume Next
    ' the foll line will save an (empty) DATEs collection keyed by the ID
    Call IDs.Add(DATEs, CStr(rgRow.Cells(1, 1).Value))  ' col 1 as the ID
    On Error GoTo 0
Next rgRow

' step 2: loop to fill each DATEs collection with the dates for that ID
For Each rgRow In rgIDsAndDates.Rows
    ' the foll line retrieves the DATEs for the corresp ID
    Set DATEs = IDs(CStr(rgRow.Cells(1, 1).Value)) ' col 1 has the ID
    Call DATEs.Add(rgRow.Cells(1, 3).Value)        ' store the date from col 3
Next rgRow

' for testing ... list the dates for ID "123"
Set DATEs = IDs("123")
Dim dt As Variant
For Each dt In DATEs
    Debug.Print "date: " & dt
    ' put that dt where you want
Next dt
0 голосов
/ 25 марта 2011

Попробуйте использовать этот код в своем коде Sheet1 ... не стесняйтесь спрашивать, если что-то не понятно.

Редактировать: Слегка измененная процедура очистки.

Private Sub Worksheet_Change (ByValTarget As Range) 

Dim oCell As Excel.Range
Dim oCellResult As Excel.Range
Dim oCellClean As Excel.Range
Dim oRangeID As Excel.Range
Dim iCellCount As Integer

If Target.Address = "$C$4" Then

    'Set source data
    Set oRangeID = Sheets(2).Range("A:A")

    'Define initial target for the results obtained
    Set oCellResult = Sheets(1).Range("F12")

    'Clear up any previous data
    'Set oCellClean = oCellResult
    'While Len(oCellClean.Value) > 0
    '    
    '    oCellClean.Clear
    '    Set oCellClean = oCellClean.Offset(1, 0)
    '    
    'Wend

    Set oCellClean = Range(oCellResult, oCellResult.End(xlDown))
    oCellClean.ClearContents

    'Scans source range for match data
    For Each oCell In oRangeID

        If oCell.Value = "" Then Exit For

        If oCell.Value = Target.Value Then

            oCellResult.Offset(iCellCount, 0).Value = oCell.Offset(0, 2).Value
            iCellCount = iCellCount + 1

        End If

    Next oCell

End If

End Sub

Редактировать:

Обновлен код очистки.Проверьте, соответствует ли оно вашим ожиданиям.

...