一致条件と貼り付け転記

Question

ID番号（列D）と一致するコードを作成し、列Bに列挙された系列に一致させようとしています。すべての一致について、コードをコピーできます列Aにコピーし、元のID番号（列D）を最初の列に入れて、転置されたSheet2に貼り付けます。私は主に動作するコードを持っています。

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 

このコードの問題は、一度に1つの列にコードを移動させる方法を理解できないことです。私は手動で "B"に変更すると動作しますが、自動的にどうすればいいですか？

レンジ（ "" & CStr関数（LCopyToRow））。私の他の問題は、このペーストを転置されていないことです

を選択します。私は2番目のステップでそれを行うことができますが、基準に合致する範囲の上限と下限を見つけることで、すべてを1ステップで実行できるはるかに簡単なコードがあるように感じます。何か示唆？

VBAで

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

：

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),"") 

---

NOTE

ID年代はあなたの例のようにグループ化されている場合、これらのメソッドの両方がのみ動作します。