[發問] 另存新檔 怎麼把欄寛跟列高也複製到新表格?

kkooo15

另存新檔 怎麼把欄寛跟列高也複製到新表格?
另外請問怎麼吧值複製過去就好，不要公式?

1空白報價單.rar (50.07 KB)

下載次數: 5

2019-11-22 12:43

1. Sub EX()
   
2. Set xSh = Sheets("報價單")
   
3. Set zSh = Sheets("請款單")
   
4. 
   
5. iPath$ = ActiveWorkbook.Path & "\" '指定路徑"
   
6. NewName$ = Format(Now, "yyyymmddhhmmss") & CStr([查表!C4])
   
7. Set ibook = ActiveWorkbook
   
8. With Workbooks.Add: ibook.Activate
   
9.   [報價單!A1:I45].Copy .Sheets(1).[A1]: .Sheets(1).Name = "報價單"
   
10.   [請款單!A1:I45].Copy .Sheets(2).[A1]: .Sheets(2).Name = "請款單"
    
11.   .SaveAs iPath & NewName: .Close True
    
12. 
    
13. End With: Set ibook = Nothing
    
14. 
    
15. 
    
16. End Sub

複製代碼

n7822123

回復 1# kkooo15


整頁複製過去應該比較快..........不用再設定欄寬列高

去掉公式很簡單，就原地複製+貼上值

順便幫你把按鈕砍掉，你新表格應該也不想有按鈕

Sub EX2()
Set xSh = Sheets("報價單")
Set zSh = Sheets("請款單")

iPath$ = ActiveWorkbook.Path & "\" '指定路徑"
NewName$ = Format(Now, "yyyymmddhhmmss") & CStr([查表!C4])
Set ibook = ActiveWorkbook
With Workbooks.Add: ibook.Activate
xSh.Copy before:=.Sheets(1)
  With ActiveSheet
    .UsedRange.Copy
    .[A1].PasteSpecial Paste:=xlPasteValues
    .Shapes(1).Delete
  End With
  zSh.Copy after:=.Sheets(1)
  With ActiveSheet
    .UsedRange.Copy
    .[A1].PasteSpecial Paste:=xlPasteValues
    .Shapes(1).Delete
  End With
  .SaveAs iPath & NewName: .Close True
  
End With: Set ibook = Nothing
End Sub

kkooo15

回復 2# n7822123
太感謝了。
原來我把簡單的事複雜化了

准提部林

Sub EX()
Dim Sht As Worksheet, xB As Workbook, N%
Application.ScreenUpdating = False
Set xB = Workbooks.Add
ThisWorkbook.Activate
For Each Sht In Sheets(Array("報價單", "請款單"))
    With Sht.Cells: .Locked = True: .FormulaHidden = True: End With
    Sht.Protect: N = N + 1
    With xB.Sheets(N): Sht.Cells.Copy .[A1]: .Name = Sht.Name: End With
    Sht.Unprotect
Next
xB.SaveAs ThisWorkbook.Path & "\" & Format(Now, "yyyymmddhhmmss") & [查表!C4], CreateBackup:=False
xB.Close
End Sub

1)將儲存格格式設為：鎖定(V)+隱藏(V)
2)複製時，將工作表設為〔保護〕，完成後再〔解除保護〕
3)這樣，公式只會貼到值，按鈕物件也不會複製過去
　
　
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

kkooo15

回復 4# 准提部林

下載 (18.29 KB)

2019-11-24 02:13

大大我用了你的方式，可是按扭還是會過去也
  是不是我用錯了什麼地方?

1空白報價單.rar (50.46 KB)

下載次數: 3

2019-11-24 02:15

准提部林

回復 5# kkooo15

可能版本不同的關係吧! 我是用2000版,
那就多一行刪物件:
Sub EX()
Dim Sht As Worksheet, xB As Workbook, N%
Application.ScreenUpdating = False
Set xB = Workbooks.Add
ThisWorkbook.Activate
For Each Sht In Sheets(Array("報價單", "請款單"))
    With Sht.Cells: .Locked = True: .FormulaHidden = True: End With
    Sht.Protect: N = N + 1
    With xB.Sheets(N)
         Sht.Cells.Copy .[A1]
        .Name = Sht.Name
        .DrawingObjects.Delete '刪除物件
    End With
    Sht.Unprotect
Next
xB.SaveAs ThisWorkbook.Path & "\" & Format(Now, "yyyymmddhhmmss") & [查表!C4], CreateBackup:=False
xB.Close
End Sub


==============================

准提部林

Sub EX3()
Dim FN$, Sht As Worksheet, xB As Workbook
FN = ThisWorkbook.Path & "\" & Format(Now, "yyyymmddhhmmss") & [查表!C4]
Set xB = Workbooks.Add
For Each Sht In ThisWorkbook.Sheets(Array("報價單", "請款單"))
    Sht.Copy Before:=xB.Sheets(1)
    With xB.Sheets(1)
         .UsedRange.Value = .UsedRange.Value
         .DrawingObjects.Delete
    End With
Next
xB.SaveAs FN, CreateBackup:=False: xB.Close
End Sub


=================================

kkooo15

回復 6# 准提部林

我的是2010
用第一個程式碼會跳出這樣

下載 (69.43 KB)

2019-11-27 09:49

第二個就正常..