Question

我正在尝试使用VBA创建备份副本。问题是，正在复制除行高以外的所有内容。我试着寻找答案，但找不到合适的东西。

这是我的代码：

Application.Workbooks.Add                           ' Neue Mappe erstellen

Dim counter As Integer
Dim wbNew As Workbook
Dim shtOld, shtNew As Worksheet
Dim pfad As String
Dim name As String

pfad = ThisWorkbook.Path
name = Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5)
'MsgBox "Aktueller Pfad: " & ThisWorkbook.Path
'MsgBox Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5)

Set wbNew = Application.Workbooks(Application.Workbooks.Count)
Do While wbNew.Worksheets.Count < ThisWorkbook.Worksheets.Count
    wbNew.Worksheets.Add                            ' Weitere Tabellen hinzufügen, falls nötig
Loop
' Tabellen kopieren

For counter = 1 To ThisWorkbook.Worksheets.Count
    Set shtOld = ThisWorkbook.Worksheets(counter)   ' Quelltabelle
    Set shtNew = wbNew.Worksheets(counter)          ' Zieltabelle
    shtNew.name = shtOld.name                       ' Tabellenname übernehmen

    shtOld.UsedRange.Copy                           ' Quelldaten und -format kopieren

    shtNew.Range("A1").PasteSpecial Paste:=8        ' Spaltenbreite übernehmen
    shtNew.UsedRange.PasteSpecial xlPasteValues     ' Werte einfügen
    shtNew.UsedRange.PasteSpecial xlPasteFormats    ' Format übernehmen


Next
wbNew.SaveAs pfad & "\" & name & " " & Format(Now, "YYYYMMDD hhmm") & ".xlsx"


Application.CutCopyMode = False      ' Zwischenspeicher löschen

＆＃39;

有人有个主意吗？太棒了！

Answer 1

您想要指定高度，而不是复制/粘贴格式。下面的代码可以帮助您入门：

Sub RowHeight()
    Dim wsOne As Worksheet: Set wsOne = ActiveWorkbook.Sheets("Sheet1")
    Dim wsTwo As Worksheet: Set wsTwo = ActiveWorkbook.Sheets("Sheet2")
    Dim RowHght As Long

    RowHght = wsOne.Range("A1").EntireRow.Height
    wsTwo.Range("A1:A10").RowHeight = RowHght
End Sub

Answer 2

如果我理解正确，那么您正尝试使用新名称作为备份保存thisWorkBook。这段代码应该更有效率。

Sub saveCopyOfThisWorkBookWithNewName()
Dim fileFrmt As Long, oldFileName As String, newFileName As String


fileFrmt = ActiveWorkbook.FileFormat
oldFileName = ThisWorkbook.FullName
newFileName = Left(oldFileName, InStrRev(oldFileName, ".") - 1) & "_" & CStr(Format(Now, "YYYYMMDD hhmm"))
ThisWorkbook.SaveCopyAs Filename:=newFileName & ".xlsx"


End Sub

VBA复制行高

2 个答案: