Board logo

標題: [發問] 複製後無法照原格式貼上???列高欄寬並沒有被覆製??? [打印本頁]
作者: t8899    時間: 2017-6-29 21:21     標題: 複製後無法照原格式貼上???列高欄寬並沒有被覆製???

這是錄製之巨集，執行後每個儲存格的列高欄寬並沒有被覆製???
    Sheets("Sheet8").Select
    Range("A1:D17").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("G6").Select
[attach]27415[/attach]
作者: t8899    時間: 2017-6-30 10:14

找到 luhpro 之前po的帖，但目的地跟來源不在同一張工作表會無效,不知如何改??

Sub nn()
  Dim lJ&, lSrc&, lTrc&, lrcs&
  Dim rSou As Range, rTar As Range
  
  Set rSou = Sheets("Sheet6").[A1:g33]' 來源
  Set rTar =Sheets("Sheet8").[a10] ' 目的
  
  rSou.Copy rTar ' 拷貝
  
'===== 逐欄複製欄寬===
  lSrc = rSou(1).Column
  lTrc = rTar(1).Column
  lrcs = rSou.Columns.Count - 1
  For lJ = 0 To lrcs
    Columns(lTrc + lJ).ColumnWidth = Columns(lSrc + lJ).ColumnWidth
  Next
  
'===== 逐列複製列高===
  lSrc = rSou(1).Row
  lTrc = rTar(1).Row
  lrcs = rSou.Rows.Count - 1
  For lJ = 0 To lrcs
    Rows(lTrc + lJ).RowHeight = Rows(lSrc + lJ).RowHeight
  Next
End Sub
作者: ML089    時間: 2017-6-30 10:52

回復 1# t8899

可以用巨集錄製

Sub ex()
    Dim rSou As Range, rTar As Range
    Set rSou = Sheets("Sheet8").Range("A1:D17")
    Set rTar = Sheets("sheet2").Range("G6")
    rSou.Copy rTar
    With rTar
        rSou.Copy
        .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                      SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                      SkipBlanks:=False, Transpose:=False
    End With
End Sub
作者: t8899    時間: 2017-6-30 11:59

本帖最後由 t8899 於 2017-6-30 12:01 編輯
回復  t8899

可以用巨集錄製

Sub ex()
    Dim rSou As Range, rTar As Range
    Set rSou = She ...
ML089 發表於 2017-6-30 10:52

可以了謝謝
本來想用 [a16].RowHeight = [a1].RowHeight 一個個解決
有這個語法  ===>  xlPasteColumnWidths
但確沒有這個語法 ==> xlPasteRowHeight
xlPasteFormats 含 xlPasteRowHeight ??
作者: t8899    時間: 2017-6-30 12:33

回復  t8899

可以用巨集錄製

Sub ex()
    Dim rSou As Range, rTar As Range
    Set rSou = She ...
ML089 發表於 2017-6-30 10:52


我又詳細測了一下  ,列高有些仍沒辦法拷 ??[attach]27416[/attach]
作者: ML089    時間: 2017-6-30 14:11

回復 5# t8899

儲存格高度沒有複製選項，只好自己做

Sub ex1()
    Dim rSou As Range, rTar As Range
    Set rSou = Sheets("Sheet4").Range("A1:d33")
    Set rTar = Sheets("sheet1").Range("a1")
    rSou.Copy rTar
    With rTar
        rSou.Copy
        .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                      SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                      SkipBlanks:=False, Transpose:=False
    End With

    For j = 1 To rSou.Rows.Count: rTar(j, 1).RowHeight = rSou(j, 1).RowHeight: Next

End Sub



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)