Question

我需要针对下面提到的问题的 Excel-VBA 解决方案。我正在使用的解决方案是完美但非常慢，几乎杀死了我的PC超过500的ID。（我有10000多个ID要处理。）

我有一些ID的开始日期和结束日期，

数据集1

ID          Trans_Date     Action
1234567890  01-Jan-2012    Active
1234567890  05-Jan-2012    Dc
1234567890  06-Jan-2012    Active
1234567890  12-Jan-2012     Dc
1234567890  15-Jan-2012    Active

我需要扩展下面的设置，

必填数据

ID          Trans_Date  Action
1234567890  01-Jan-12   Active
1234567890  02-Jan-12   Active
1234567890  03-Jan-12   Active
1234567890  04-Jan-12   Active
1234567890  05-Jan-12   DC
1234567890  06-Jan-12   Active
1234567890  07-Jan-12   Active
1234567890  08-Jan-12   Active
1234567890  09-Jan-12   Active
1234567890  10-Jan-12   Active
1234567890  11-Jan-12   Active
1234567890  12-Jan-12   DC
1234567890  13-Jan-12   DC
1234567890  14-Jan-12   DC
1234567890  15-Jan-12   Active

目前我正在使用下面给出的公式。

（感谢Tom Sharpe）

1) Copy the first ID number into D2

(2) Put this formula in D3

=IF(COUNTIF(D$1:D2,D2)<(MAX(IF(A$2:A$20=D2,B$2:B$20))-MIN(IF(A$2:A$20=D2,B$2:B$20))+1),
   D2,
   INDEX($A$2:$A$20, MATCH(0, COUNTIF($D$1:D2, $A$2:$A$20), 0)))
(3) Put this formula in E2:-

=MIN(IF(A$2:A$20=D2,B$2:B$20))+COUNTIF(D$1:D1,D2)
(4) Put this formula in F2:-

=INDEX(C$2:C$20,MATCH(E2,IF(A$2:A$20=D2,B$2:B$20),1))
All these are array formulae and must be entered with CtrlShiftEnter

但即使他建议使用VBA。怎么在VBA中做到？

你能帮帮我吗？

提前谢谢。

Answer 1

这样的事情应该可以解决问题。您需要根据数据的位置修改工作表引用和列。扩展数据现在将列在第二张表中。

Sub ExpandData()

Dim SourceRow, TargetRow As Long
Dim LastDate, NextDate As Date
Dim DateDiff, FillDate As Integer
SourceRow = 2
TargetRow = 2

'Loop through source rows
Do While Sheets(1).Range("A" & CStr(SourceRow)).Value <> ""
    LastDate = Sheets(1).Range("B" & CStr(SourceRow)).Value
    ' Check for the last row of data and use todays date if last row
    If Sheets(1).Range("B" & CStr(SourceRow + 1)).Value <> "" Then
        NextDate = Sheets(1).Range("B" & CStr(SourceRow + 1)).Value
    Else
        NextDate = Date
    End If
    DateDiff = NextDate - LastDate
    ' create a row in the target sheet for each date in between those in the source sheet
    For FillDate = 0 To DateDiff - 1
        Sheets(2).Range("A" & CStr(TargetRow)).Value = Sheets(1).Range("A" & CStr(SourceRow)).Value
        Sheets(2).Range("B" & CStr(TargetRow)).Value = LastDate + FillDate
        Sheets(2).Range("C" & CStr(TargetRow)).Value = Sheets(1).Range("C" & CStr(SourceRow)).Value
        TargetRow = TargetRow + 1
    Next FillDate

    SourceRow = SourceRow + 1
Loop

End Sub

Answer 2

试试这个：

Option Compare Text
Sub test()
    Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    Dim cl As Range, i&, z&, x&, key As Variant
    i = Cells(Rows.Count, "A").End(xlUp).Row
    z = 1
    For Each cl In Range("A2:A" & i)
    x = 1
    If cl = cl.Offset(1, 0) And _
        Trim(cl.Offset(, 2)) <> Trim(cl.Offset(1, 2)) Then
            Dic.Add z, cl & "|" & cl.Offset(, 1) & "|" & cl.Offset(, 2)
            While cl.Offset(, 1) + x < cl.Offset(1, 1)
                z = z + 1
                Dic.Add z, cl & "|" & cl.Offset(, 1) + x & "|" & cl.Offset(, 2)
                x = x + 1
            Wend
    Else
        Dic.Add z, cl & "|" & cl.Offset(, 1) & "|" & cl.Offset(, 2)
    End If
    z = z + 1
    Next cl
    Workbooks.Add
    x = 2: [A1] = "ID": [B1] = "Trans_Date": [C1] = "Action"
    For Each key In Dic
        Range(Cells(x, "A"), Cells(x, "C")) = Split(Dic(key), "|")
        x = x + 1
    Next key
    Columns("A:C").AutoFit
End Sub

<强>来源

输出结果

Excel- VBA：给定开始日期和结束日期，创建两个

2 个答案: