Создание новой копии только с значениями - Excel VBA

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), и копия должна содержать только значения." Übersicht AP-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, чтобы она использовалась в качестве текущего диапазона столбца.Похоже, что ваше утверждение 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")

Ваш следующий оператор Select в Sub SubstitudeFieldValues() станет:

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