將垂直列表轉換爲水平列表當列A，B和E發生更改時開始新行

我有一個需要從垂直轉爲水平的數據列表...我想通過VBA執行操作，因爲我有約40K行。我需要將每個數字組的所有數據與相同類型的prod和G/NG代碼結合起來。因此，所有具有相同類型，督促，G/NG和號碼必須與所有從該行的代碼列一列....將垂直列表轉換爲水平列表當列A，B和E發生更改時開始新行

例如

與

Number|Type | Code |Prod |G/NG | 
:----:|:----:|:----:|:----:|:----:| 
440  AF  1234 S7  G 
440  AF  7865 S7  G 
440  NY  1235 S7  G 
440  NY  4567 S7  G 
41MM AF  1234 S7  G 
41MM AF  1235 S7  NG

啓動

現在應該是這樣的：

Number|Type | Code1 | Code2| Prod |G/NG | 
:----:|:----:|:----: |:----:|:-----:|:----:| 
440  AF  1234 7865 S7  G

來源

2016-12-12 DWS

因爲G/NG不匹配，41mm仍然是兩行嗎？ –

它可以使用數組公式來完成，不需要VBA，是列中還是單個單元格？ –

我已經無法獲得任何我已經嘗試過的工作。我試圖做一個匹配公式，但沒有奏效，我想不出一種VBA的方式來做到這一點，這就是爲什麼我在這裏我已經完成了VBA在一列的休息，但沒有一個是爲3列。 – DWS

這是在這個網站，在反應的細節，你在你的問題表現出的努力相匹配很常見......讓我們面對它，你的顯示幾乎沒有。您也需要提供一些您已經嘗試過的代碼，但無法像您期望的那樣工作。我從你以前的問題中注意到，你只是發佈了你在網上找到的代碼，並要求人們爲你調整它。因此，本網站上的大多數受訪者都會疑惑這個：你是否想要解除其他人的代碼並修改它，或者你真的想學習VBA？

我打算假設它是後者（希望你未來的問題能夠展示一些'第一原則'的編碼），並幫助你解決這個問題。雖然這是一個相當平凡的項目，但它有一些煩瑣的方面，我可以看到你不知道從哪裏開始。

你基本上有兩個任務：

你有多少獨特的行根據自己的標準查找，
查找代碼的最大數量。

第一個任務只是一個循環遍歷每一行並查看每個細節組合是否爲新的情況。有很多方法可以做到這一點 - 下面的代碼使用Collection與詳細信息組合作爲關鍵。

對於第二項任務，您需要將所有代碼添加到其各自的產品中，並記錄最大代碼數。您會在示例代碼中看到我已經使用了第二個Collection。

還有很多其他的方式來處理這個問題（例如鋸齒狀的數組），並且如果每個產品的細節都不是唯一的，那麼您就必須獲得更多的創意。

一旦你有適當的劃分數據，你會然後填充你的項目的輸出數組的每一行，並將數組寫入您的工作表。在下面的代碼中，我已將它寫入Sheet2，以便您不會丟失原始數據。

所以，這裏是我希望能讓你開始的代碼。請儘量自己解決，並確保你瞭解它......這意味着避免在這篇文章中添加評論，這些評論符合「哦，這樣一條線不起作用。」

Dim data As Variant 
Dim products As Collection, details As Collection, codes As Collection 
Dim detailsKey As String 
Dim code As Variant, output() As Variant 
Dim maxCodeSize As Long 
Dim r As Long, c As Long 

'Read data into array 
With Sheet1 '~~> adjust this to your data sheet 
    data = .Range(.Cells(2, 1), .Cells(.Rows.Count, 5).End(xlUp)).Value2 
End With 

'Loop through rows to create unqiue product entries 
Set products = New Collection 
For r = 1 To UBound(data, 1) 

    'Create the keys 
    detailsKey = CStr(data(r, 1)) & "|" & _ 
       CStr(data(r, 2)) & "|" & _ 
       CStr(data(r, 4)) & "|" & _ 
       CStr(data(r, 5)) 

    'Test if product exists 
    Set details = Nothing 
    On Error Resume Next 
    Set details = products(detailsKey) 
    On Error GoTo 0 

    'If it doesn't exist add a new product to collection 
    If details Is Nothing Then 
     Set details = New Collection 
     With details 
      .Add data(r, 1), "NUMBER" 
      .Add data(r, 2), "TYPE" 
      .Add data(r, 4), "PROD" 
      .Add data(r, 5), "G/NG" 
      .Add New Collection, "CODES" 
     End With 
     products.Add details, detailsKey 
    End If 

    'Add the codes, keeping a note of max code count 
    Set codes = details("CODES") 
    codes.Add data(r, 3) 
    If maxCodeSize < codes.Count Then 
     maxCodeSize = codes.Count 
    End If 

Next 

'Size the output array 
ReDim output(1 To details.Count + 1, 1 To 4 + maxCodeSize) 

'Fill header row 
output(1, 1) = "Number" 
output(1, 2) = "Type" 
For c = 1 To maxCodeSize 
    output(1, 2 + c) = "Code" & c 
Next 
output(1, 3 + maxCodeSize) = "Prod" 
output(1, 4 + maxCodeSize) = "G/NG" 

'Fill data rows 
r = 2 
For Each details In products 
    output(r, 1) = details("NUMBER") 
    output(r, 2) = details("TYPE") 
    c = 1 
    Set codes = details("CODES") 
    For Each code In codes 
     output(r, 2 + c) = code 
     c = c + 1 
    Next 
    output(r, 3 + maxCodeSize) = details("PROD") 
    output(r, 4 + maxCodeSize) = details("G/NG") 
    r = r + 1 
Next 

'Write output to Sheet2 
Sheet2.Range("A1").Resize(UBound(output, 1), UBound(output, 2)).Value = output

來源

2016-12-13 00:53:10 Ambie

將垂直列表轉換爲水平列表當列A，B和E發生更改時開始新行

回答

相關問題