我有大约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
答案 0 :(得分:2)
我认为你的主要问题是在代码底部递增两次(通过'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