VBA 复制行高
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/42003081/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA copy row height
提问by Felicce
I am trying to create a backup copy with VBA. The problem is, that everything except the row height is being copied. I tried looking for an answer, but couldnt find anything that fits.
我正在尝试使用 VBA 创建备份副本。问题是，除了行高之外的所有内容都被复制。我试图寻找答案，但找不到任何合适的答案。
Here's my code:
这是我的代码：
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
'
'
Anyone got an idea? Would be great!
有人有想法吗？会很好！
采纳答案by User632716
You want to assign the height, rather than copy/paste formatting. The code below should get you started:
您想要分配高度，而不是复制/粘贴格式。下面的代码应该让你开始：
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
回答by John Muggins
If I understand correctly then you are trying to save thisWorkBook with a new name as a backup. This code should do it a little more efficiently.
如果我理解正确，那么您正在尝试使用新名称保存此工作簿作为备份。这段代码应该更有效地完成它。
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
