VBA复制行高
VBA复制行高
提问于 2017-02-02 21:08:02
我正在尝试使用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‘
有谁有主意吗？那就太好了！
回答 3
Stack Overflow用户
回答已采纳
发布于 2017-02-02 21:40:28
您希望指定高度，而不是复制/粘贴格式。下面的代码应该可以让您开始使用：
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 SubStack Overflow用户
发布于 2017-02-02 22:20:49
如果我理解正确的话，那么您正在尝试使用新名称保存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 SubStack Overflow用户
发布于 2021-12-15 14:04:17
您需要选择、复制和粘贴行，以获得要粘贴的行高
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/42003081
复制相关文章
相似问题
腾讯云开发者
