Excel VBA - 三重嵌套循環將列鍵綁在一起

Question

我試圖建立一個嵌套循環，只有在問題列有數據時才能將不同列連接在一起。

什麼我已經是這樣的一個表：

|Aname  |aterm |amod  | 
|   |   |   | 
|Smith, Bob |   |   | 
|   |   |   | 
|   |   |   | 
|   | 2/6/2017|   | 
|   |   |   | 
|   |   |Module 1 | 
|   |   |   | 
|Smith, John |   |   | 
|   |   |   | 
|   |   |   | 
|   |5/12/2017|   | 
|   |   |Module 6 | 
|   |   |   | 
|   |   |Module 4 | 
|   |   |   | 
|   |6/12/2017|   | 
|   |   |   | 
|   |   |Module 10| 
|   |   |Module 5 | 

我所要做的是扳平列在一起，就像這樣：

|aname  |aterm  |amod  | 
|Smith, Bob | 02/6/2017 | Module 1 | 
|Smith, John | 5/12/2014 | Module 6 | 
|Smith, John | 5/12/2014 | Module 4 | 
|Smith, John | 6/12/2014 | Module 10 | 
|Smith, John | 6/12/2014 | Module 5 | 

下面是我放在一起拉碼這關閉。不幸的是，印刷數十次，間歇性地進行印刷，並沒有完全滿足。

Sub looper() 

Dim rng As Range 
Dim rng2 As Range 
Dim rng3 As Range 

aname = "" 
aterm = "" 
amod = "" 

Set listenroll = [table1[aname]] 
Set atermrange = [table1[aterm]] 
Set amodrange = [table1[amod]] 

For Each rng In listenroll 
    If IsEmpty(rng) = False Then 
     Set aname = rng 
     For Each rng2 In atermrange 
      If IsEmpty(rng2) = False Then 
       Set aterm = rng2 
       For Each rng3 In amodrange 
        If IsEmpty(rng3) = False Then 
         Set amodrange = rng3 
         Range("I1").End(xlDown).Offset(1, 0) = aname 
         Range("J1").End(xlDown).Offset(1, 0) = aterm 
         Range("K1").End(xlDown).Offset(1, 0) = amod 
        End If 
       Next rng3 
      End If 
     Next rng2 
    End If 
Next rng 

有誰知道問題是什麼嗎？

Answer 1

你只需要一個循環：

Sub looper() 

    Dim aname As String 
    'Dim aterm As String 
    Dim aterm As Date 
    Dim amod As String 

    aname = "" 
    'aterm = "" 
    aterm = 0 
    amod = "" 

    Set listenroll = [table1[aname]] 
    Set atermrange = [table1[aterm]] 
    Set amodrange = [table1[amod]] 

    Dim r As Long 
    For r = 1 to amodrange.Rows.Count 
     'Record value of AName whenever it changes 
     If Trim(listenroll(r, 1).Value) <> vbNullString Then 
      aname = Trim(listenroll(r, 1).Value) 
     End If 
     'Record value of ATerm whenever it changes 
     If Trim(atermrange(r, 1).Value) <> vbNullString Then 
      'aterm = Trim(atermrange(r, 1).Value) 
      aterm = CDate(atermrange(r, 1).Value) 
     End If 
     'Write output each time there is something in amod 
     If Trim(amodrange(r, 1).Value) <> vbNullString Then 
      amod = Trim(amodrange(r, 1).Value) 
      Range("I1").End(xlDown).Offset(1, 0) = aname 
      Range("J1").End(xlDown).Offset(1, 0) = aterm 
      Range("K1").End(xlDown).Offset(1, 0) = amod 
     End If 
    Next 

注：我不知道如何修改aterm，以配合您的問題的例子，但我希望這只是在本例中一個錯字。

---

而且，FWIW，你有一個重大的錯誤在該點現有的代碼，你說Set amodrange = rng3。我不確定是否只有錯誤。

Answer 2

我有替代解決方案給你。這與YowE3K的代碼基本相同，但是還有一個for循環和一個更少的if語句。這是因爲，不是使用表名，而是使用列A B C，假定您的表存在，並且還將值存儲在數組中。

試試這個：

Sub looper() 
Dim i As Long, j As Long, LastCell As Long 
Dim arr() As String 
ReDim arr(2) 
With Sheets("Sheet1") 
    LastCell = .UsedRange.Rows.Count 
    For i = 2 To LastCell 
     For j = 1 To 3 
      If Not IsEmpty(.Cells(i, j)) Then 
       arr(j - 1) = .Cells(i, j) 
       If j = 3 Then 
        .Cells(.Rows.Count, "I").End(xlUp).Offset(1, 0) = arr(0) 
        .Cells(.Rows.Count, "J").End(xlUp).Offset(1, 0) = arr(1) 
        .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0) = arr(2) 
       End If 
      End If 
     Next j 
    Next i 
End With 
End Sub