VBA复制行高

我正在尝试使用VBA创build备份副本。 问题是，除了行高以外的所有东西都被复制了。 我试图寻找答案，但无法find任何适合的。

这是我的代码：

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 

“

任何人有一个想法？ 会很好！

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

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

 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