VBA copy row height

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 

'

Кто есть идея? Было бы замечательно!

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