使用Excel和VBA將記錄從重復行移動到列

Question

我有大約70,000行數據和兩列（Field，Data），每50-100行（記錄）重復一次。 我想寫一些東西來搜索基於“字段文本”的值（我只對大約5個字段感興趣），然后將值粘貼到一個新的工作表中，其中行作為記錄，列作為字段。 我要搜索的第一個字段將需要指示新的行/記錄。

我第一次嘗試失敗，並且在論壇上找不到任何幫助。 盡管看起來數據透視表可以做到這一點？

可視化我想做什么： 示例

編輯：

我得到了想要的結果，但是直到“ END”都沒有解決。 我在數據的最后一個單元格中有“ END”。 另外，我確定有更有效的方法來執行此操作，有什么建議嗎？ 謝謝！

Sub TracePull()

Dim i As Long
Dim j As Long

i = 1
j = 1

ActiveWorkbook.Sheets("Trace").Range("A1").Select

Do Until Range("A" & i) = "END"

Do Until ActiveCell = "OTDRFilename"
    i = i + 1
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop

If ActiveCell = "OTDRFilename" Then
    ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
    ActiveWorkbook.Sheets("Sheet1").Range("A" & j + 1).PasteSpecial Paste:=xlValue
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
    i = i + 1
    j = j + 1
'Else
'    i = i + 1
End If

Range("A" & i).Select

Do Until ActiveCell = "OTDRSpan length"
    i = i + 1
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop

If ActiveCell = "OTDRSpan length" Then
    ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
    ActiveWorkbook.Sheets("Sheet1").Range("B" & j).PasteSpecial Paste:=xlValue
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
    i = i + 1
End If

Range("A" & i).Select

Do Until ActiveCell = "OTDRSpan loss"
    i = i + 1
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop

If ActiveCell = "OTDRSpan loss" Then
    ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
    ActiveWorkbook.Sheets("Sheet1").Range("C" & j).PasteSpecial Paste:=xlValue
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
    i = i + 1
End If

Range("A" & i).Select

Do Until ActiveCell = "OTDRAverage loss"
    i = i + 1
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop

If ActiveCell = "OTDRAverage loss" Then
    ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
    ActiveWorkbook.Sheets("Sheet1").Range("D" & j).PasteSpecial Paste:=xlValue
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
    i = i + 1
End If

Range("A" & i).Select

Do Until ActiveCell = "OTDRSpan ORL"
    i = i + 1
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop

If ActiveCell = "OTDRSpan ORL" Then
    ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
    ActiveWorkbook.Sheets("Sheet1").Range("E" & j).PasteSpecial Paste:=xlValue
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
    i = i + 1
End If

Range("A" & i).Select

Do Until ActiveCell = "OTDRWavelength"
    i = i + 1
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop

If ActiveCell = "OTDRWavelength" Then
    ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
    ActiveWorkbook.Sheets("Sheet1").Range("F" & j).PasteSpecial Paste:=xlValue
    ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
    i = i + 1
End If

i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select

Range("A" & i).Select

Loop

End Sub

Answer 1

我認為您的主要問題是在代碼底部將i增加兩次（通過“ END”單元格）。

一種使其更具可讀性的方法是使用選擇大小寫。 另外，由於您有70,000行，因此可以直接分配值（不帶復制粘貼）並關閉屏幕更新來加快代碼的速度。 這些事情將大大提高性能。

Sub TracePull()

  ScreenUpdating = False

  Dim i As Long
  Dim j As Long

  i = 1
  j = 1

  ActiveWorkbook.Sheets("Trace").Range("A1").Select

    Do Until Range("A" & i) = "END"
      Select Case ActiveCell.Text
        Case "OTDRFilename"
          ActiveWorkbook.Sheets("Sheet1").Range("A" & j + 1).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value

        Case "OTDRSpan length"
          ActiveWorkbook.Sheets("Sheet1").Range("B" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value

        Case "OTDRSpan loss"
          ActiveWorkbook.Sheets("Sheet1").Range("C" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value

        Case "OTDRAverage loss"
          ActiveWorkbook.Sheets("Sheet1").Range("D" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value

        Case "OTDRSpan ORL"
          ActiveWorkbook.Sheets("Sheet1").Range("E" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value

        Case "OTDRWavelength"
          ActiveWorkbook.Sheets("Sheet1").Range("F" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
        End Select

      i = i + 1
      j = j + 1
      ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
    Loop
    ScreenUpdating = True
End Sub

---

您可能還想考慮定義工作簿和工作表，而不是依賴活動表。 另外，如果有人忘記在最后一個單元格中輸入“ END”，則帶有中斷的代碼，因此也許只是使用最后一個單元格而不是尋找“ END”

  Dim wb As Workbook
  Dim wskA As Worksheet
  Dim wskB As Worksheet

  wb = ActiveWorkbook
  wskA = wb.Sheets("Trace")
  wskB = wb.Sheets("Sheet1")

  numofrows = wskA.Offset(wskA.Rows.Count - 1, 0).End(xlUp).Row
  wskA.Range("A1").Select

    Do Until i > numofrows
      Select Case ActiveCell.Text
        Case "OTDRFilename"
          wskB.Range("A" & j + 1).Value = wskA.Range("B" & i).Value