0

我在寻找我的问题的答案时发现了这个论坛。我发现这里发布的解决方案：

如何将每个工作表保存在 Excel 2010 工作簿中以使用宏分隔 CSV 文件？

我很抱歉没有评论那篇文章，但我找不到这样做的选项。所以，我发布这个问题。

我没有使用 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
4

2 回答 2

1

试试这个代码（未经测试）

我有

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

  2. 我已经介绍了错误处理，这是您调整时必须的Application Settings

试一试，让我知道现在是否有任何不同。

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
于 2012-06-19T03:58:17.483 回答
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
于 2012-06-25T13:45:30.310 回答