Question

我有大约70,000行数据和两列（字段，数据），每50-100行重复一次（记录）。我想写一些基于“Field Text”搜索值的东西（我只对大约5个字段感兴趣）并将值粘贴到一个新的工作表中，其中行作为记录，列作为字段。我正在搜索的第一个字段需要指明新的行/记录。

我的第一次尝试失败了，我在论坛上找不到任何帮助。虽然看起来像一个数据透视表可能会这样做？

我想做什么的视觉： Example

编辑：

我得到了我想要的结果，但直到“结束”才抓到。我在数据的最后一个单元格中有“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

我认为你的主要问题是在代码底部递增两次（通过'END'单元格）。

使其更具可读性的一种方法是使用select case。此外，您可以通过直接分配值（无需复制粘贴）和关闭屏幕更新来加速代码，因为您有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

使用Excel和VBA将记录从重复行移动到列

1 个答案: