每个工作表的 VBA 循环

Posted 2023-03-16

【中文标题】每个工作表的 VBA 循环

【英文标题】：VBA Loop For Each Worksheet

【发布时间】：2021-09-11 15:55:42

【问题描述】：

我正在编写代码以基本上浏览我的工作簿中的每个工作表，然后选择删除并在完成时将所有工作表保存到 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 xWs 但 Range("A3").Select 指的是活动工作表。也许你需要点，即.Range().Columns()和.Cells()

@SuperSymmetry 此代码不是选择删除其他工作表中的选择，它只是删除激活工作表中的选择，但将所有工作表保存在工作簿中。对不起我的语言，我的英语不太好

@CDP1802 for with 和点我有错误 Method or data member not found

【参考方案1】：

当使用带点的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