將數據重新格式化爲另一個Excel工作表

Question

我正在爲文件夾中的多個文本文件進行主題建模。我已經將最終的綜合文本文件中的數據導入到excel中。它的格式如下。整數表示主題，小數表示該文本文件中發生該主題的百分比。

| C | | D     |   | E | | F     |   | G | | H |           |   I   |   | Ĵ               |
| 2 | | 0.85 |   | 1 | | 0.05 |   | 0 | | 0.012 |   | 3 | | 0.004 | ....
| 0 | | 0.50 |   | 2 | | 0.31 |   | 3 | | 0.146 |     | 1 | | 0.068 | ...

主題編號需要成爲列標題，並且百分比在下面。我需要將數據按以下格式重新格式化爲另一張：

| D |             | E     |     | F         | | G         |
| 0 |               | 1           |       | 2         |   |           | ... | n |
| 0.012 | | 0.05 |       | 0.85 | | 0.004 |
| 0.50     | | 0.068 |   | 0.31 | | 0.146 |

每個文本文件將具有相同的主題數量，但主題數量可能會有所不同。因此，這個例子有4個主題，但另一個可能有20,25等。我嘗試使用items方法，但它看起來像我將不得不硬編碼那裏的值。有沒有另一種方法來做到這一點？

下面是我的源數據的模樣：

Source Data in Excel

我試過，但一直被卡住：

Sub Items_Ex() 

Dim myColumn As Long myRow = 2 
While Worksheets("Input_Format_A").Cells(2, myColumn).Value <> "" 

Dim myRow As Long myRow = 3 
While Worksheets("Input_Format_A").Cells(myRow, 3).Value <> "" 
Dim d As Dictionary Dim a, i 'Create some variables 
Set d = New Dictionary 
d.Add "1", Worksheets("Input_Text").Cells(1, 8).Value 
d.Add "2", Worksheets("Input_Text").Cells(1, 6).Value 
d.Add "3", Worksheets("Input_Text").Cells(1, 4).Value 'Do until there are no more topics 
a = d.Items 'Get the items For i = 0 To d.Count - 1 'Iterate the array 
Debug.Print a(i) 'Print item Next 

Debug.Print d.Item("b") 
myRow = myRow + 1 
Wend 
Wend 

End Sub 

Answer 1

• 首先，它得到最高的主題中的源範圍的源表單（活動表單）。

• 然後每個主題數中搜索源範圍內，發現然後當鄰居被複制到新的工作表

  Private Const NEW_SHEET_NAME As String = "NewSheetName" 
  Private Const FIRST_TARGET_ROW = 9 
  Private Const FIRST_TARGET_COLUMN = 4 
  Private Const FIRST_SOURCE_CELL As String = "c2" 
  
  Sub test() 
  
      Dim sourceSheet As Worksheet 
      Set sourceSheet = ActiveSheet 
      If (sourceSheet.UsedRange Is Nothing) Then Exit Sub 
  
      Dim sourceRange As Range 
      Set sourceRange = Application.Intersect(sourceSheet.UsedRange, sourceSheet.Range(FIRST_SOURCE_CELL & ":" & sourceSheet.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Address)) 
  
      Dim maxTopic As Byte 
      maxTopic = CByte(Application.WorksheetFunction.Max(sourceRange)) 
  
      Dim data() As Variant 
      data = sourceRange.Value 
  
      Dim newSheet As Worksheet 
      Set newSheet = ThisWorkbook.Worksheets.Add 
      newSheet.Name = NEW_SHEET_NAME 
  
      Dim topic As Byte 
      Dim i As Integer 
      Dim j As Integer 
      Dim item As Variant 
      For topic = 0 To maxTopic 
       newSheet.Cells(FIRST_TARGET_ROW, FIRST_TARGET_COLUMN + topic).Value = topic 
       For i = LBound(data, 1) To UBound(data, 1) 
        For j = LBound(data, 2) To UBound(data, 2) 
         item = data(i, j) 
         If (IsEmpty(item)) Then GoTo next_item 
         If (item = topic) Then 
          With newSheet 
           If (j + 1 <= UBound(data, 2)) Then 
            .Cells(.Cells(.Rows.Count, FIRST_TARGET_COLUMN + topic).End(xlUp).Row + 1, FIRST_TARGET_COLUMN + topic).Value = data(i, j + 1) 
           End If 
          End With 
         End If 
  next_item: 
        Next j 
       Next i 
      Next topic 
  
  End Sub