非常慢的宏，没有它更快？

时间：2012-06-18 22:44:30

标签： excel excel-vba csv vba

我在搜索问题的答案时找到了这个论坛。我找到了解决方案：

How do I save each sheet in an Excel 2010 workbook to separate CSV files with a macro?

我为没有评论该帖子而道歉，但我找不到这样做的选项。所以，我发布了这个问题。

我没有使用zip功能，只是创建CSV文件并排除部分工作表。如您所见，我也在做一些查找/替换功能和刷新数据。

它工作正常，但需要很长时间才能运行（1-1 / 2小时）。如果我删除保存功能，并手动保存每张纸，可以在几分钟内完成。

什么让它陷入困境？

下面的代码（抱歉格式不佳）

Sub Worksheet_Macro()
' Category_Trail Macro
' Macro breaks category trail down into individual categories. TO BE USED ONLY IN THE "WORKSHEET" SHEET
'

'

 Dim ws As Worksheet
 Dim strMain As String
 Dim lngCalc As Long

 strMain = "C:\Users\David Cox\Documents\TotalOutdoorsman\Site\Inventory\Daily Upload Files\"


' Turn off calculations
 With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
 End With

'Update all Data

    ActiveWorkbook.RefreshAll

'Copy and Paste Categories and create trail

    Sheets("Worksheet").Select
    Range("Ah2:Ah20000").Select
    Selection.Copy
    Range("Ai2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("Ai2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True


' Clean_Description Macro
' Macro copies and pastes product descriptions to new column and then cleans them of HTML code.
'
'
    Range("AO2:AO20000").Select
    Selection.Copy
    Range("AP2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Columns("AP:AP").Select
    Selection.Replace What:="<br>", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="</br>", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

' Remove Appostrophies Macro
    Sheets("RSR Inventory").Select
    Columns("L:L").Select
    Range("L5743").Activate
    Selection.Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets("Valor Inventory").Select
    ActiveWindow.LargeScroll ToRight:=-1
    Columns("C:C").Select
    Selection.Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

' Go back to Main Product Page
    Sheets("MainProductPage").Select

'Turn Calculations back on
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Calculation = lngCalc
End With

'Save before creating CSV Files
ThisWorkbook.Save

' Turn off calculations
 With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
 End With

'Save all CSV files
For Each ws In ActiveWorkbook.Worksheets
    Select Case ws.Name
    Case "Imported Product Data", "Sheet 2", "Sheet 3"
    'do nothing for these sheets
    Case Else
    ws.SaveAs strMain & ws.Name, xlCSV
    End Select
Next

'Turn Calculations back on
 With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Calculation = lngCalc
 End With

End Sub

2 个答案:

答案 0 :(得分：1)

尝试此代码（未经测试）

我有

  1. 删除了许多不必要的代码，例如.Select，.LargeScroll以及使您的宏变慢的事件。

  2. 我已经介绍了错误处理，在您调整Application Settings

    3. 时必须这样做

    尝试一下，如果现在有任何不同，请告诉我。

    Sub Worksheet_Macro()
    Dim ws As Worksheet
    Dim strMain As String
    Dim lngCalc As Long

    On Error GoTo Whoa

    strMain = "C:\Users\David Cox\Documents\TotalOutdoorsman\Site\Inventory\Daily Upload Files\"

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    With Sheets("Worksheet")
        .Range("AH2:AH20000").Copy
        With .Range("AI2")
            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

            .TextToColumns Destination:=.Range("AI2"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
            TrailingMinusNumbers:=True
        End With

        .Range("AO2:AO20000").Copy

        .Range("AP2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

        With .Columns("AP:AP")
            .Replace What:="<br>", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False

            .Replace What:="</br>", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        End With
     End With

    With Sheets("RSR Inventory")
        .Columns("L:L").Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    End With

    With Sheets("Valor Inventory")
        .Columns("C:C").Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    End With

    '~~> Save before creating CSV Files
    ThisWorkbook.Save

    '~~> Save all CSV files
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
        Case "Imported Product Data", "Sheet 2", "Sheet 3"
            'do nothing for these sheets
        Case Else
            ws.SaveAs strMain & ws.Name, xlCSV
        End Select
    Next
LetsContinue:
     '~~> Reset Settings
     With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = lngCalc
        .CutCopyMode = False
     End With

     MsgBox "Done"
     Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

答案 1 :(得分：0)

我明白了！我决定为每个CSV分别使用Excel文件。它以这种方式更快地节省了它们。总运行时间现在在6分钟范围内！以下是我最终的结果：

Sub Worksheet_Macro()
' Category_Trail Macro
' Macro breaks category trail down into individual categories. TO BE USED ONLY IN THE "WORKSHEET" SHEET
'

'
Dim counter As Integer 'declare variable
Dim fname As String
Dim fname1 As String
Dim fileext As String
Dim csvfname As String
Dim directory As String

directory = "C:\Files\"


' Turn off visual feedback to speed up process
 With Application
    .DisplayAlerts = False
    .ScreenUpdating = False

 End With

'Update all Data

    ActiveWorkbook.RefreshAll

    Sheets("Worksheet").Select
    Range("Ah2:Ah15000").Select
    Selection.Copy
    Range("Ai2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("Ai2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True


' Clean_Description Macro
' Macro copies and pastes product descriptions to new column and then cleans them of HTML code.
'
'
    Range("AO2:AO15000").Select
    Selection.Copy
    Range("AP2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Columns("AP:AP").Select
    Selection.Replace What:="<br>", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="</br>", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

' Remove Appostrophies Macro
    Sheets("RSR Inventory").Select
    Columns("L:L").Select
    Range("L5743").Activate
    Selection.Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets("Valor Inventory").Select
    ActiveWindow.LargeScroll ToRight:=-1
    Columns("C:C").Select
    Selection.Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

' Go back to Main Product Page
    Sheets("MainProductPage").Select



'Save all files


counter = 2 'initialize variable
Sheets("Save As Info").Select
Range("a2").Select '1st cell with file name

Do Until ActiveCell = "" 
    fname1 = Cells(counter, 1) 
    'this is set for column A
    filext = Cells(counter, 2) 
    fname = directory & fname1 & fileext 
    csvfname = directory & fname1 & "CSV.csv" 
    Workbooks.Open Filename:=fname 



    ActiveWorkbook.SaveAs Filename:=csvfname, FileFormat:=xlCSV, CreateBackup:=False
    'save as csv

    ActiveWorkbook.Close SaveChanges:=False 'close csv


    Windows("UpdateWorkbook.xlsm").Activate 'select workbook with file info
    Sheets("Save As Info").Select 'select sheet with file info

    counter = counter + 1
    ActiveCell.Offset(1, 0).Range("a1").Select 'This moves down the column


Loop

'Turn on visual feedback
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True

End With

    ActiveWorkbook.Close SaveChanges:=False 'close Excel File

End Sub
相关问题
最新问题