Question

我必须编写一个代码，将两张纸的副本复制到新的工作簿中。但是，我收到错误消息，并且值不显示。

    Public Sub CopySheetAndRename()
    Dim newName As String

    On Error Resume Next
    newName = InputBox("Enter the name for the copied worksheet")

    If newName <> "" Then
        ActiveSheet.Copy After:=Worksheets(Sheets.Count)
        On Error Resume Next
        ActiveSheet.Name = newName
    End If
    End Sub

    Sub SaveSheets()
    Application.DisplayAlerts = False

    Dim myFile
    Dim myCount
    Dim actSheet
    Dim i
    Dim WsTabelle As Worksheet

    'mypath = InputBox("Enter the path", "Save to...", "C:\temp")
    mypath = "C:\temp"
    ChDrive mypath
    ChDir mypath

    Sheets("Fertigstellungsgrad aktuell").Select
    Sheets("Fertigstellungsgrad aktuell").Copy Before:=Sheets("Fertigstellungsgrad aktuell")
    Sheets("Fertigstellungsgrad aktuell").Select
    Sheets("Fertigstellungsgrad aktuell (2)").Name = "Fertigstellungsgrad xx.xx.xx"

    ActiveWorkbook.SaveAs Filename:= _
         "C:\temp\Bearbeitungsstatus.xlsm" _
         , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

    ' Löschen überflüssiger Sheets
    For Each WsTabelle In Sheets
        With WsTabelle
            ' Dein Makro, Cells und Range mit Punkt
            actSheet = .Name
            If .Name = "Fertigstellungsgrad xx.xx.xx" Then
              ' mache nichts
              actSheet = .Name
            ElseIf .Name = "Übersicht AP-Verbrauch" Then
              ' mache nichts
              actSheet = .Name
            Else
              WsTabelle.Delete
            End If
        End With
    Next WsTabelle

    ActiveWorkbook.SaveAs Filename:= _
         " C:\temp \Bearbeitungsstatus.xlsm" _
         , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False


    End Sub
Public Sub SubstitudeFieldValues()
    Sheets("Fertigstellungsgrad xx.xx.xx").Select
    ' Find the last row of data
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    FinalCol = Cells(1, Columns.Count).End(xlToLeft).Column
    ' Loop through each row
   For Col = 1 To FinalCol
        colTitle = Cells(1, Col).Value
        If colTitle = "K1" Or _
           colTitle = "K2" Or _
           colTitle = "K3" Or _
           colTitle = "S1" Or _
           colTitle = "S2" Or _
           colTitle = "S3" Or _
           colTitle = "P1" Or _
           colTitle = "P2" Or _
           colTitle = "P3" Or _
           colTitle = "T1" Or _
           colTitle = "T2" Or _
           colTitle = "T3" Or _
           colTitle = "A1" Or _
           colTitle = "A2" Or _
           colTitle = "D1" Or _
           colTitle = "D2" Then

            For x = 2 To FinalRow
                wert = Cells(x, Col)
                If wert <> Leer Then
                    'Range(Cells(x, Col), Cells(x, Col)).Select
                    Cells(x, Col).Select
                    Selection.Copy
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False
                End If
            Next x
        End If
    Next Col
End Sub

原始任务是在新工作簿中复制两张纸。复制具有重命名功能的“ Fertigstellungsgrad ”（应称为“ Fertigstellungsgrad xx.xx.xx”-Date.Month.Year），并且该副本中应仅包含值。 “ ÜbersichtAP-Verbrauch ”（此名称应保持不变，没有任何更改）

https://i.stack.imgur.com/Soxq7.png

问候，马里奥

Answer 1

Sub SaveSheets()的文件名中有空格

我更改了：

ActiveWorkbook.SaveAs Filename:= _
     " C:\temp \Bearbeitungsstatus.xlsm" _
     , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

到

ActiveWorkbook.SaveAs Filename:= _
     "C:\temp\Bearbeitungsstatus.xlsm" _
     , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

我可以保存文件。

我将下面的代码从IF / FOR修改为CASE SELECT，并将FinalRow变量的范围修改为当前列使用范围。看来您在Sub中的For / Next语句是伪代码，因此我没有对其进行任何更改。

Public Sub SubstitudeFieldValues()
    Sheets("Fertigstellungsgrad xx.xx.xx").Select
    ' Find the last row of data
    'FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    FinalCol = Cells(1, Columns.Count).End(xlToLeft).Column
    ' Loop through each row

    For Col = 1 To FinalCol

        colTitle = Cells(1, Col).Value

    Select Case colTitle
    Case "K1", "K2", "K3", "S1", "S2", "S3", "P1", "P2", "P3", "T1", "T2", "T3", "A1", "A2", "D1", "D2"
        FinalRow = Range(colTitle).End(xlDown).Row
    Case else
        goto NotFound
    End Select

            For x = 2 To FinalRow
                wert = Cells(x, Col)
                If wert <> Leer Then
                    'Range(Cells(x, Col), Cells(x, Col)).Select
                    Cells(x, Col).Select
                    Selection.Copy
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False
                End If
            Next x

NotFound:
    Next Col
End Sub

要设置新表的名称以包括日期，可以在SaveSheets（）中从以下位置更改代码：

Sheets("Fertigstellungsgrad aktuell (2)").Name = "Fertigstellungsgrad xx.xx.xx"

到

Sheets("Fertigstellungsgrad aktuell (2)").Name = "Fertigstellungsgrad " & Format(Now(), "dd.mm.yy")

您在Sub SubstitudeFieldValues()中的后续Select语句将变为：

Public Sub SubstitudeFieldValues()
    Sheets("Fertigstellungsgrad " & Format(Now(), "dd.mm.yy").Select

仅使用值制作新副本-Excel VBA

1 个答案: