Question

我正在尝试编写一个与ID号匹配的代码（D列），并将其与B列中列出的系列相匹配。对于所有匹配，我希望能够复制A列中的代码并粘贴它转换为Sheet2，在第一列中包含原始ID号（列D）。我有一个主要有效的代码。

Sub History()

    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer
    Dim loop_ctr As Integer

    'Start search in row 4
    LSearchRow = 4

    'Start copying data to row 2 in Sheet2 (row counter variable)
    LCopyToRow = 2
    columnncopy = 2
    A = A

        While Len(Range("D" & CStr(LSearchRow)).Value) > 0

        For loop_ctr = 4 To 4

            'If value in column E = "Mail Box", copy entire row to Sheet2
             If Range("E" & CStr(LSearchRow)).Value = Range("G" & loop_ctr) Then

                'Select row in Sheet1 to copy
                Range("D" & CStr(LSearchRow)).Select
                Selection.Copy

                'Paste row into Sheet2 in next row
                Sheets("Sheet2").Select
                Range("A" & CStr(LCopyToRow)).Select
                'CStr(LCopyToRow)).Select
                ActiveSheet.Paste



                'Move counter to next row
                LCopyToRow = LCopyToRow + 1

                'Go back to Sheet1 to continue searching
                Sheets("Sheet1").Select

            End If

            LSearchRow = LSearchRow + 1

              Next loop_ctr

         Wend



    'Position on cell A3
    Application.CutCopyMode = False
    Range("A3").Select

    'MsgBox "All matching data has been copied."

    Exit Sub


End Sub

这段代码的问题在于我无法弄清楚如何让代码一次移动一列。我知道如果我手动进入并将其更改为＆＃34; B＆＃34;，但我该如何自动完成？

范围（＆＃34; A＆＃34;＆amp; CStr（LCopyToRow））。选择

我的另一个问题是，这不是转贴粘贴。我可以在第二步中做到这一点，但我觉得有一个更简单的代码应该能够通过查找匹配条件的范围的上限和下限一步完成所有操作。有什么建议吗？

Date     ID Number      Find    Paste matching dates horizontally       
1/12/2005   PTA123      PTA123          
1/2/2007    PTA123      PTA456          
1/31/2007   PTA123      PTA786          
2/28/2007   PTA123                  
5/23/2007   PTA123                  
6/20/2007   PTA123                  
6/3/2009    PTA123                  
7/2/2009    PTA123                  
7/1/2014    PTA123                  
8/4/2014    PTA123                  
9/11/2014   PTA123                  
10/23/2014  PTA123                  
12/4/2014   PTA123                  
2/13/2013   PTA456                  
3/13/2013   PTA456                  
4/10/2013   PTA456                  
5/10/2013   PTA456                  
6/7/2013    PTA456                  
7/22/2013   PTA456                  
10/7/2010   PTA786                  
11/4/2010   PTA786                  
12/2/2010   PTA786                  
12/30/2010  PTA786                  
1/28/2011   PTA786                  
2/25/2011   PTA786

Answer 1

在vba中：

Sub ffff2()
Dim ws As Worksheet
Dim rng As Range

Dim inptrowed As Long
Dim cntrng As Long
Dim lstrow As Long

Set ws = Sheets("Sheet6") 'Change to your sheet

lstrow = ws.Evaluate("MATCH(""ZZZ"", D:D)")

cntrng = 2 'Start row on D

Do Until cntrng > lstrow
    Dim inptrowst As Variant
    inptrowst = ws.Evaluate("MATCH(D" & cntrng & ",B:B,0)")
    If Not IsError(inptrowst) Then
        inptrowed = ws.Evaluate("COUNTIF(B:B,D" & cntrng & ")")
        Set rng = ws.Range(ws.Cells(inptrowst, 1), ws.Cells(inptrowst + inptrowed - 1, 1))
        ws.Cells(cntrng, 5).Resize(, inptrowed).Value = Application.Transpose(rng)
    End If
    cntrng = cntrng + 1
Loop

End Sub

这也可以通过公式，放入E2并上下复制来完成：

=IF(COLUMN(A:A)<=COUNTIF($B:$B,$D2),INDEX($A:$A,MATCH($D2,$B:$B,0)+COLUMN(A:A)-‌1),"")

注意

这两种方法只有在ID被分组时才会起作用。

匹配条件和粘贴转置

1 个答案: