0

私の問題に対する答えを探しているときに、このフォーラムを見つけました。ここに投稿されたソリューションを見つけました：

Excel 2010 ブックの各シートを保存して、マクロを使用して CSV ファイルを分離するにはどうすればよいですか?

その投稿にコメントしなかったことをお詫びしますが、そうするオプションが見つかりませんでした. だから、私はこの質問を投稿しています。

CSVファイルを作成し、一部のシートを除外するだけで、zip機能は使用していません。ご覧のとおり、いくつかの検索/置換機能とデータの更新も行っています。

実行に非常に長い時間 (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 に答える