Question

我有一个数据数组，它的屏幕截图将链接到本文的底部。行和列引用是截图。

我正在尝试编写一个宏，它将在动态范围（列H）中输出发生的所有日期。然后在第一列中，我希望列标题 @ 行，即I4。

但是如果这个日期有超过1个计数，我希望第二个学校输出到第J列。就像它将于26/03/18那样，看起来像这样：

h5 = 26/03/18，i5（Event1）=任务2 @ 1，j5（事件2）=任务2 @ 4

我今天尝试了很多方法，希望得到一些帮助。

到目前为止

我的代码（对于更复杂的表格）：

Sub Events()
'How many schools there are
Dim sh As Worksheet
' This needs to change for each sheets
Set sh = ThisWorkbook.Sheets("Easter 18")
Dim k As Long

k = sh.Range("A3").End(xlDown).Row 'Counts up from bottow - Number of schools attained
Ro = Range("M52").value = k - 2 'Elimiates the two top rows as headers

'Now I need to search the Range of dates
Dim TaskDates As Range
Dim StartCell  As Range 'First part of Array
Dim EndCell As Range 'End of Array
Set EndCell = Range("J" & 2 + k) 'maybe 2 or 3
Set StartCell = Range("G3")
Set TaskDates = Range(StartCell, EndCell) 'Dynamic Range

'Within the range of data print out the most left row header (school name) - and task with @ in the middle - ascending
' If Column has date (true) create a table with Date (col 1), Event (col 2), Event 2 (Col3) etc etc
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant
varray = TaskDates.value

'Generate unique list and count
For Each element In varray
If dict.exists(element) Then
    dict.item(element) = dict.item(element) + 1
   Else
    dict.Add element, 1
   End If
Next

   'Paste report somewhere -
   'First line ouptuts the dates occured
   sh.Range("M55").Resize(dict.Count).value =     'Was working now saying syntax error for this line. 
       WorksheetFunction.Transpose (dict.keys)
   ' The count works if cell format is correct
   CDates = sh.Range("N55").Resize(dict.Count, 1).value = _
       WorksheetFunction.Transpose(dict.items)
End Sub

如果您认为合适，请随时重新设计。

Answer 1

对此有所了解。只有几个嵌套循环测试日期，确保找到的日期已经列在日期列下。正如我之前所说，如果找到超过3个日期，你从未说过要做什么，所以我不得不添加第四个事件列并假设它是最大值。在任何地方，任何超过4个日期都不会被记录，仅供参考。

Sub MoveDates()

Dim i As Long, j As Long, sht As Worksheet, lastrow As Long, lastrow2 As Long, refrow As Long

Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row + 1

For i = 4 To lastrow
    For j = 3 To 6
        If Cells(i, j).Value <> "" And Cells(i, j).Value <> "n/a" Then
            If Not Application.WorksheetFunction.CountIf(Range("H4:H" & lastrow), Cells(i, j)) > 0 Then
                lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row + 1
                Range("H" & lastrow2).Value = Cells(i, j).Value

                If Range("I" & lastrow2).Value = "" Then
                    Range("I" & lastrow2).Value = Cells(3, j).Value & " @ " & Cells(i, 2).Value
                ElseIf Range("J" & lastrow2).Value = "" Then
                    Range("J" & lastrow2).Value = Cells(3, j).Value & " @ " & Cells(i, 2).Value
                ElseIf Range("K" & lastrow2).Value = "" Then
                    Range("K" & lastrow2).Value = Cells(3, j).Value & " @ " & Cells(i, 2).Value
                ElseIf Range("L" & lastrow2).Value = "" Then
                    Range("L" & lastrow2).Value = Cells(3, j).Value & " @ " & Cells(i, 2).Value
                End If

            Else
                lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row

                For k = 4 To lastrow2
                    If Range("H" & k).Value = Cells(i, j).Value Then
                        refrow = k
                        Exit For
                    End If
                Next k

                If Range("I" & refrow).Value = "" Then
                    Range("I" & refrow).Value = Cells(3, j).Value & " @ " & Cells(i, 2).Value
                ElseIf Range("J" & refrow).Value = "" Then
                    Range("J" & refrow).Value = Cells(3, j).Value & " @ " & Cells(i, 2).Value
                ElseIf Range("K" & refrow).Value = "" Then
                    Range("K" & refrow).Value = Cells(3, j).Value & " @ " & Cells(i, 2).Value
                ElseIf Range("L" & refrow).Value = "" Then
                    Range("L" & refrow).Value = Cells(3, j).Value & " @ " & Cells(i, 2).Value
                End If
            End If
        End If
    Next j
Next i

End Sub

Answer 2

你可以这样走

Option Explicit

Sub Tasks()
    Dim cell As Range, f As Range

    With Worksheets("schools") 'change "schools" to your actual sheet name
        For Each cell In .Range("C4:F" & .Cells(.Rows.Count, "B").End(xlUp).Row) 'reference its column C:F from row 4 down to column B last not empty cell
            If IsDate(cell.value) Then 'if current cell value is a valid date
                Set f = .Range("H3", .Cells(.Rows.Count, "H").End(xlUp)).Find(what:=cell.value, lookat:=xlWhole, LookIn:=xlValues) 'try finding the date in column H
                If f Is Nothing Then Set f = .Cells(.Rows.Count, "H").End(xlUp).Offset(1) 'if date not already in column H then get its first empty cell after last not empty one 
                f.value = cell.value 'write the date (this is sometimes not necessary, but not to "ruin" the code)
                .Cells(f.Row, .Columns.Count).End(xlToLeft).Offset(, 1).value = .Cells(3, cell.Column).value & " @" & .Cells(cell.Row, 2).value ' write the record in the first not empty cell in the "date" row
            End If
        Next
    End With
End Sub

从

2 个答案: