时间戳

首页 > 解决方案 > 制作仅包含值的新副本 - Excel VBA

excel - 制作仅包含值的新副本 - Excel VBA

问题描述

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

    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

亲切的问候，马里奥

标签： excelvba

解决方案

文件名中有空格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")

您随后的 Select 语句Sub SubstitudeFieldValues()将变为：

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

推荐阅读