每个工作表的 VBA 循环

如何解决每个工作表的 VBA 循环

我正在编写代码以基本上浏览我的工作簿中的每个工作表，然后选择删除并在完成时将所有工作表保存到 csv。我没有收到任何错误，但它也只保存工作表。 非常感谢任何帮助！

Public Sub SaveWorksheetsAsCsv()

Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog

Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In Application.ActiveWorkbook.Worksheets

    With xWs
   Range("A3").Select
   Range(Selection,Selection.End(xlToRight)).Select
   Range(Selection,Selection.End(xlDown)).Select
   Selection.copy
   Range("AU1").Select
   Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats,Operation:= _
        xlNone,SkipBlanks:=False,Transpose:=False
   Columns("A:AT").Select
   Range("AT1").Activate
   Application.CutcopyMode = False
   Selection.Delete Shift:=xlToLeft
   Range("A1").Select
   Cells.Replace What:="(puste)",Replacement:="",LookAt:=xlPart,_
        SearchOrder:=xlByRows,MatchCase:=False,SearchFormat:=False,_
        ReplaceFormat:=False,FormulaVersion:=xlReplaceFormula2
    End With

xWs.SaveAs Filename:=xDir & "\" & xWs.Name,FileFormat:=xlCSV,Local:=True

Next
End Sub

解决方法

使用带点的 With 前缀范围时。

Option Explicit

Public Sub SaveWorksheetsAsCsv()

    Dim xWs As Worksheet,xDir As String,msg As String
    Dim folder As FileDialog
    
    Set folder = Application.FileDialog(msoFileDialogFolderPicker)
    If folder.Show <> -1 Then Exit Sub
    xDir = folder.SelectedItems(1)
   
    Application.ScreenUpdating = False
    For Each xWs In Application.ActiveWorkbook.Worksheets
    
        With xWs
            msg = msg & vbCrLf & xWs.Name
            .Range(.Range("A3"),.Range("A3").End(xlToRight).End(xlDown)).Copy
            .Range("AU1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats,Operation:= _
                 xlNone,SkipBlanks:=False,Transpose:=False
            Application.CutCopyMode = False
            .Columns("A:AT").Delete Shift:=xlToLeft
           
            .UsedRange.Cells.Replace What:="(puste)",Replacement:="",LookAt:=xlPart,_
                 SearchOrder:=xlByRows,MatchCase:=False,SearchFormat:=False,_
                 ReplaceFormat:=False ',FormulaVersion:=xlReplaceFormula2
            .SaveAs Filename:=xDir & "\" & .Name,FileFormat:=xlCSV,Local:=True
            '.Activate ' optional
            '.Range("A1").Select ' optional
        End With

    Next
    Application.ScreenUpdating = True
    MsgBox "Sheets saved :" & msg,vbInformation
End Sub