Question

我已经通过修补我可以在网上找到的几个代码片段来编译代码（哪个工作正常）。由于对VBA的了解非常有限，我无法进一步调整它以使其更有效地运行。如果工作表中的行太多，则需要一段时间才能运行。

我需要在excel文件中运行代码，该文件由Acrobat 10从pdf文件中定期创建。自动创建工作表“表1”，整个数据为表格。我在下面的代码，尝试提取表的一部分，并在同一工作簿中的表“结果”上创建一个新的输出。代码还会创建另一个工作表“Result2”，用于临时保存一些数据，然后删除工作表。

希望有人可以整理这些代码以便有效地工作，因为我有时需要处理大约15000行的工作表。

Option Explicit
Sub DefectDescription()
Dim lngLastRow As Long
Dim lngRow As Long
Dim strValue As String
Dim lngRowOutput As Long
Sheets.Add.Name = "Result"
Sheets("Result").Move After:=Sheets("Table 1")
' where does the data end in Sheet(Table 1)
lngLastRow = Sheets("Table 1").UsedRange.Rows.Count
If lngLastRow = 1 Then Exit Sub ' no data
' Clear down sheet (Result), assume we have column headings in row 1 we want  to keep
Sheets("Result").Range("2:1048576").Clear

lngRowOutput = 2 ' where are we going to write the values to in Sheet(Result) when we find a "Defect Description" phrase

For lngRow = 1 To lngLastRow
strValue = Sheets("Table 1").Cells(lngRow, 1).Value ' get value from column A
If InStr(1, strValue, "Defect Description", vbTextCompare) > 0 Then ' can we find "Defect Description :" in the text
Sheets("Table 1").Rows(lngRow).Offset(2, 0).Copy
Sheets("Result").Rows(lngRowOutput).PasteSpecial
       lngRowOutput = lngRowOutput + 1
End If
Next lngRow
Call FinalAction
Application.DisplayAlerts = False
Sheets("Result2").Delete
With Sheets("Result")
Sheets("Result").Cells.UnMerge
End With      
'the below lines of code is used to delete blank columns after unmerging cells
Sheets("Result").Columns(3).EntireColumn.Delete
Sheets("Result").Columns(3).EntireColumn.Delete
Sheets("Result").Columns(3).EntireColumn.Delete
Sheets("Result").Columns(6).EntireColumn.Delete
Sheets("Result").Columns(12).EntireColumn.Delete
Sheets("Result").Columns(12).EntireColumn.Delete
Sheets("Result").Columns(12).EntireColumn.Delete
Sheets("Result").Columns(12).EntireColumn.Delete
Sheets("Result").Columns(12).EntireColumn.Delete
Sheets("Result").Columns(12).EntireColumn.Delete
Sheets("Result").Columns(12).EntireColumn.Delete
Sheets("Result").Columns(12).EntireColumn.Delete
End Sub
Sub FinalAction()
Dim lngLastRow As Long
Dim lngRow As Long
Dim strValue As String
Dim lngRowOutput As Long
Sheets.Add.Name = "Result2"
' where does the data end in Sheet(Table 1)
lngLastRow = Sheets("Table 1").UsedRange.Rows.Count
If lngLastRow = 1 Then Exit Sub ' no data
' Clear down sheet (Result2), assume we have column headings in row 1 we want to keep
Sheets("Result2").Range("2:1048576").Clear
lngRowOutput = 2 ' where are we going to write the values to in Sheet(Result2)   when we find a "Final Action" phrase
For lngRow = 1 To lngLastRow
strValue = Sheets("Table 1").Cells(lngRow, 1).Value ' get value from column A
If InStr(1, strValue, "Final Action", vbTextCompare) > 0 Then ' can we find "Defect Description :" in the text
Sheets("Table 1").Rows(lngRow).Offset(2, 0).Copy
Sheets("Result2").Rows(lngRowOutput).PasteSpecial
lngRowOutput = lngRowOutput + 1
End If
Next lngRow
With Worksheets("Result2")
.Range("A1:M" & .Cells(Rows.Count, "M").End(xlUp).Row).Copy     Destination:=Sheets("Result").Range("N1")
End With
End Sub

Answer 1

这应该快两倍（一个循环代替2）。我只是将FinalAction子的相关部分集成到DefectDescription中，没有原始数据和预期输出的提取，这很难做得更多。如果有不清楚或没有足够的评论部分，请随时发表评论。

Option Explicit
Sub DefectDescription()
  Dim lngLastRow As Long
  Dim lngRow As Long
  Dim strValue As String
  Dim lngRowOutput As Long

  Sheets.Add.Name = "Result"
  Sheets.Add.Name = "Result2"
  Sheets("Result").Move After:=Sheets("Table 1")

  ' where does the data end in Sheet(Table 1)
  lngLastRow = Sheets("Table 1").UsedRange.Rows.Count
  If lngLastRow = 1 Then Exit Sub ' no data

  ' Clear down sheet (Result), assume we have column headings in row 1 we want  to keep
  Sheets("Result").Range("2:1048576").Clear
  Sheets("Result2").Range("2:1048576").Clear

  lngRowOutput1 = 2 ' where are we going to write the values to in Sheet(Result) when we find a "Defect Description" phrase
  lngRowOutput2 = 2 ' same for result2

  For lngRow = 1 To lngLastRow
    strValue = Sheets("Table 1").Cells(lngRow, 1).Value ' get value from column A
    Sheets("Table 1").Rows(lngRow).Offset(2, 0).Copy
    If InStr(1, strValue, "Defect Description", vbTextCompare) > 0 Then ' can we find "Defect Description :" in the text
      Sheets("Result").Rows(lngRowOutput1).PasteSpecial
      lngRowOutput1 = lngRowOutput1 + 1
    End If
    If InStr(1, strValue, "Final Action", vbTextCompare) > 0 Then
      Sheets("Result2").Rows(lngRowOutput2).PasteSpecial
      lngRowOutput2 = lngRowOutput2 + 1
    End If
  Next lngRow

  With Worksheets("Result2")
    .Range("A1:M" & .Cells(Rows.Count, "M").End(xlUp).Row).Copy Destination:=Sheets("Result").Range("N1")
  End With

  Application.DisplayAlerts = False
  Sheets("Result2").Delete
  With Sheets("Result")
    Sheets("Result").Cells.UnMerge
  End With

  'the below lines of code is used to delete blank columns after unmerging cells
  Sheets("Result").Columns(3).EntireColumn.Delete
  Sheets("Result").Columns(3).EntireColumn.Delete
  Sheets("Result").Columns(3).EntireColumn.Delete
  Sheets("Result").Columns(6).EntireColumn.Delete
  Sheets("Result").Columns(12).EntireColumn.Delete
  Sheets("Result").Columns(12).EntireColumn.Delete
  Sheets("Result").Columns(12).EntireColumn.Delete
  Sheets("Result").Columns(12).EntireColumn.Delete
  Sheets("Result").Columns(12).EntireColumn.Delete
  Sheets("Result").Columns(12).EntireColumn.Delete
  Sheets("Result").Columns(12).EntireColumn.Delete
  Sheets("Result").Columns(12).EntireColumn.Delete
End Sub

vba excel代码编辑

1 个答案: