将数据重新格式化为另一个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