整合來自多列的數據

Question

我的問題是類似的，但比這個線程更復雜How to Consolidate Data from Multiple Excel Columns All into One Column。

這裏是示例Excel

Date  Measure1 A B  Date  Measure2 A B C Date..... 
11/11/11 1234  1  2  11/12/12 5678  1 3 3 12/12/12 ... 
12/11/12 234  34 234 12/12/13 345  342 23 33 12/12/13 ... 
........ 

有在Excel中幾百列。一個日期列後跟一個測量列，然後是其他一些列。 現在我只想要日期列，度量名稱列和值列。 結果excel文件想

Date  Measure Name  Value 
11/11/11 Measure1   1234 
11/12/12 Measure2   5678 
12/12/12 .... 
.... 
12/11/12 Measure1   234 
12/12/13 Measure2   123 

我怎麼可能通過VBA實現呢？由於我有這樣的數千個文件，VBA似乎是合併這些文件並加載到數據庫的最佳方式。

我總是

Run-time error '1004' 
    Application -defined or object -defined eror" 

在

w.Sheets("DataSort").Range("A1").Resize(k, UBound(Arr2, 2)) = Arr2 

這裏是我的代碼

Sub convertExcel() 
Dim Arr1, Arr2() 
Dim Rnum As Integer, Cnum As Integer, Tnum As Integer 
Dim i As Integer, j As Integer, k As Integer 
'Rnum = row number; Cnum = column number; Tnum as total number 

Application.ScreenUpdating = False 
Set w = Workbooks.Open("FileNAME~~~~") 
Rnum = w.Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row 

Cnum=208 
Tnum = Rnum * Cnum/2 
w.Sheets.Add.Name = "DataSort" 

Arr1 = Range("A1:GZ" & Rnum) 
ReDim Arr2(1 To Tnum, 1 To 3) 

For j = 2 To Cnum 
    If w.Sheets("Data").Cells(1, j) = "Date" Then 
    For i = 2 To Rnum 
    If Arr1(i, j) <> "" Then 
     k = k + 1: 
     Arr2(k, 1) = Arr1(i, j) 
     Arr2(k, 2) = Arr1(1, j) 
     Arr2(k, 3) = Arr1(i, j + 1) 
    End If 
    Next 
    End If 
Next 


w.Sheets("DataSort").Range("A1").Resize(k, UBound(Arr2, 2)) = Arr2 

w.Close True 
Application.ScreenUpdating = True 
End Sub 

Answer 1

由於我有很多時間在今天我的手，我決定花一些時間在這裏。我覺得這有點具有挑戰性，但最終，這只是適當的事件排序。

以下是我所使用的邏輯：

• 刪除所有非Date和非MeasureX列。
• 將所有列名以Measure存儲在字典中（完全不必要，但是，嘿，它很快）作爲鍵。
• 迭代第一個字典的鍵並創建第二個字典以將日期 - 值對存儲爲鍵值對。
• 每次迭代，我們在第二張紙上打印出鍵值對。

請仔細閱讀代碼中的所有註釋。另外，請記下我的設置。最後，請在您的工作簿副本上進行測試。

設置：

在Sheet2，我已經從您的例如具有1508列和1500行的數據，但不包括報頭大致複製一個刪節數據集。刪除不需要的列後，數據將減少爲734列和1500行數據。在測試中，刪除大約需要11-13秒。您的里程可能會有所不同。

使用這個過濾的數據，使用第二個字典對它進行處理大約需要8-9秒來完成。整個過程基本結束約20秒。

屏幕截圖：

Sheet 2中（表與原始數據）：

表Sheet 3（輸出片）：

代碼：

：

Sub KamehameWave() 

    Dim Sht2 As Worksheet, Sht3 As Worksheet 
    Dim Dict As Object, Cell As Range 
    Dim Dict2 As Object, Cell2 As Range 
    Dim RngToDelete As Range 

    Set Sht2 = ThisWorkbook.Sheets("Sheet2") 'Modify accordingly. 
    Set Sht3 = ThisWorkbook.Sheets("Sheet3") 'Modify accordingly. 

    Application.ScreenUpdating = False 

    With Sht2 
     '-----------------------------------BK201's Notes-----------------------------------' 
     ' The following block will delete unneeded columns. Basically, it will only keep ' 
     ' columns that either have "Date" or "MeasureX" in their headers. All else will be ' 
     ' discarded. As said in the post, do this on a copy of your worksheet.    ' 
     '-----------------------------------BK201's Notes-----------------------------------' 
     Start = Timer() 
     For Each Cell In .Rows(1).Cells 
      If InStr(1, Cell.Value, "Date") = 0 And InStr(1, Cell.Value, "Measure") = 0 Then 
       If Not RngToDelete Is Nothing Then 
        Set RngToDelete = Union(RngToDelete, .Columns(Cell.Column)) 
       Else 
        Set RngToDelete = .Columns(Cell.Column) 
       End If 
      End If 
     Next Cell 
     RngToDelete.Delete 
     Debug.Print Timer() - Start 
     Start = Timer() 
     '-----------------------------------BK201's Notes-----------------------------------' 
     ' The following block will create a dictionary and store all the names of columns ' 
     ' with "Measure" in them. This is just so you have a reference. An array or a  ' 
     ' collection will do as well. I prefer to use this though as I find it easier.  ' 
     '-----------------------------------BK201's Notes-----------------------------------' 
     Set Dict = CreateObject("Scripting.Dictionary") 
     For Each Cell In .Rows(1).Cells 
      CheckIfMeasure = InStr(1, Cell.Value, "Measure") 
      If CheckIfMeasure > 0 Then 
       If Not Dict.Exists(Cell.Value) And Not IsEmpty(Cell.Value) Then 
        Dict.Add Cell.Value, Empty 
       End If 
      End If 
     Next Cell 
     '-----------------------------------BK201's Notes-----------------------------------' 
     ' What we'll do next is to iterate over each "MeasureX" column. We'll iterate over ' 
     ' the values on these columns and store them in a *second* dictionary, with their ' 
     ' respective dates being the keys.             ' 
     '-----------------------------------BK201's Notes-----------------------------------' 
     For Each Key In Dict 
      MColIndex = Application.Match(Key, .Rows(1), 0) 
      MColLRow = .Cells(Rows.Count, MColIndex).End(xlUp).Row 
      Set MCol = .Range(.Cells(2, MColIndex), .Cells(MColLRow, MColIndex)) 
      Set Dict2 = CreateObject("Scripting.Dictionary") 
      For Each Cell2 In MCol 
       If Not Dict2.Exists(Cell2.Value) And Not IsEmpty(Cell2.Value) Then 
        Dict2.Add Cell2.Offset(0, -1).Value, Cell2.Value 
       End If 
      Next Cell2 
     '-----------------------------------BK201's Notes-----------------------------------' 
     ' The final phase is to get the next empty row in the output sheet and dump all the ' 
     ' key-value pairs from our second dictionary there. Since we're also iterating  ' 
     ' through the keys of the first dictionary, the list will append properly to  ' 
     ' accommodate each key's own dictionary.           ' 
     '-----------------------------------BK201's Notes-----------------------------------' 
      TColNRow = Sht3.Range("A" & Rows.Count).End(xlUp).Row + 1 
      Sht3.Range("A" & TColNRow).Resize(Dict2.Count, 1).Value = Application.Transpose(Dict2.Keys) 
      Sht3.Range("B" & TColNRow).Resize(Dict2.Count, 1).Value = Key 
      Sht3.Range("C" & TColNRow).Resize(Dict2.Count, 1).Value = Application.Transpose(Dict2.Items) 
     Next Key 
     Debug.Print Timer() - Start 
    End With 

    Application.ScreenUpdating = True 

End Sub 

運行代碼後結果

第一個數字是刪除的運行時間，第二個是換位。考慮到我有50萬個數據點，這並不壞。對數據進行排序在您的法庭上。

讓我們知道這會有所幫助。