skyutm

回復 8# GBKEE
抱歉！版大又要打擾一下，小弟我想有關貼圖位置的語法應該是這一段吧
            .Top = 照片位置.Top                             '圖片:頂端位置
            .Left = 照片位置.Left                           '圖片:左邊位置
我想改成置中
            .center = 照片位置.center                            '圖片:頂端位置
            .cenetr = 照片位置.cenetr                           '圖片:左邊位置
或這樣
                .Top = 照片位置.center                             '圖片:頂端位置
               .Left = 照片位置.cenetr                           '圖片:左邊位置
或這樣
            .Top = 照片位置.xlcenetr                             '圖片:頂端位置
            .Left = 照片位置.xlcenetr                           '圖片:左邊位置
都不行，請問該如何修改呢？謝謝！

stillfish00

回復 11# skyutm
你可能誤會了 , Top和Left是指設定圖片上緣和左緣的座標位置 , 不是對齊方式~
置中一般是說文字在儲存格內的對齊方式 , 圖片應該沒這種設定?

skyutm

回復 12# stillfish00
是喔？那麼，那貼圖的位置是否有語法可以改變呢？

GBKEE

回復 13# skyutm

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh As Worksheet, M(1 To 2) As String, E As Range
   
4.     Set Sh = ActiveSheet
   
5.     'Set 照片位置 = Sh.[d5]
   
6.     With ActiveSheet
   
7.         .Pictures.Delete                                    '刪除工作表全部圖片(如還有其餘樣式的 Shape 會一併刪除)
   
8.         For Each E In .[a1:a10]                            '*****[a1:a10] 已有姓名*****
   
9.             M(1) = E
   
10.             M(2) = Mid(E, 1, 2) & Chr(10) & Mid(E, 3, IIf(Len(E) < 3, 1, Len(E) - 2)) & "印"
    
11.             With E
    
12.             .FormulaR1C1 = M(2)
    
13.             .Font.Size = 14
    
14.             .Font.ColorIndex = 3
    
15.             .Font.Name = "華康古印體(P)"                    '修改你PC上的字體
    
16.             .HorizontalAlignment = xlCenter
    
17.             .VerticalAlignment = xlCenter
    
18.             .WrapText = True
    
19.             .EntireRow.AutoFit                              '自動調整列高
    
20.             .Copy
    
21.         End With
    
22.         With .Pictures.Paste
    
23.             .Placement = xlMoveAndSize
    
24.             .PrintObject = True
    
25.             
    
26.             '*********** 圖片貼在[B1:B10]     *******
    
27.             .Top = E.Offset(, 1).Top                        '圖片:頂端位置
    
28.             .Left = E.Offset(, 1).Left                      '圖片:左邊位置
    
29.             E.Offset(, 1).RowHeight = E.RowHeight           '圖片貼在[B1:B10] 調整 列高
    
30.             E.Offset(, 1).ColumnWidth = E.ColumnWidth       '圖片貼在[B1:B10] 調整 欄寬
    
31.              '*********** 圖片貼在[B1:B10]     *******
    
32.             
    
33.             .ShapeRange.Fill.Visible = msoTrue              '圖片背景 顯示
    
34.            ' .ShapeRange.Fill.ForeColor.SchemeColor = 41    '背景顏色
    
35.              .ShapeRange.Line.Visible = msoTrue             '圖片邊框 顯示
    
36.             .ShapeRange.Line.Weight = 0.75                  '邊框.厚度
    
37.           '  .ShapeRange.Line.Visible = msoTrue
    
38.             .ShapeRange.Line.ForeColor.SchemeColor = 10     '圖片邊框.顏色
    
39.          '   .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    
40.         End With
    
41.         E.Clear
    
42.         E = M(1)
    
43.         Next
    
44.     End With
    
45. End Sub

複製代碼

skyutm

抱歉！還是要感謝版大熱心的教導，不過因為小弟覺得太複雜了。所以研究了這麼一段時間之後。我又去找了些語法，只是在圖片貼上之後，做一些調整移動。
    With Sheets("成績單")
    For i = 0 To j
             .Paste Destination:=.Range("d" & 22 + 26 * i)
             .Pictures.ShapeRange.IncrementLeft 45
             .Pictures.ShapeRange.IncrementTop 5
    Next i
    End With
但是又有問題ㄝ，因為迴圈會一直跑，所以會看到執行時，印章會一直不斷的移動，最前面的印章會移動最多次，甚至跑出範圍（由時會覺得很蠢！）所以又改成：
    With Sheets("成績單")
    For i = 0 To j
             .Paste Destination:=.Range("d" & 22 + 26 * i)
    Next i
             .Pictures.ShapeRange.IncrementLeft 45
             .Pictures.ShapeRange.IncrementTop 5
    End With
就是在迴圈跑完，印章都貼完之後，在一起移動圖片，但是，因為活頁簿裡也有其他圖片，所以也會跟著移動。真是傷腦筋。有沒有語法是在迴圈複製一張圖片之後，就立刻移動。下一張複製時就不會再移動到了？

GBKEE

回復 15# skyutm

1. With Sheets("成績單")
   
2.     For i = 0 To j
   
3.              .Paste Destination:=.Range("d" & 22 + 26 * i)
   
4.     Next i
   
5.              .Pictures.ShapeRange.IncrementLeft 45
   
6.              .Pictures.ShapeRange.IncrementTop 5
   
7.            '**** 也會跟著移動*****       .Pictures -> Sheets("成績單")的所有圖片
   
8.     End With

複製代碼

試試看

1. With Sheets("成績單")
   
2.     For i = 0 To j
   
3.              .Paste Destination:=.Range("d" & 22 + 26 * i)
   
4.               a = .Pictures.Count
   
5.              .Pictures(a).ShapeRange.IncrementLeft 45
   
6.              .Pictures(a).ShapeRange.IncrementTop 5
   
7.     Next i
   
8.     End With

複製代碼

skyutm

回復 16# GBKEE

啊！我懂了，版大就是比較聰明（狗腿），把貼上的圖片加上編號，就可以準確控制已貼上圖片的移動位置，也就不會移動到其他圖片了。

skyutm

回復 16# GBKEE
抱歉！狗腿是有目的的，還有一個未解開的問題要請教！
小弟的構想是想要在成績輸入完成之後另存新檔，也在本論壇和網路上做過功課，修改後的語法如下
Sub macor24()
Dim a, b, u, v, r, n As String
    a = Sheets("基本設定").Range("a6").Value
    b = Sheets("基本設定").Range("a8").Value
    u = Sheets("基本設定").Range("j1").Value
    v = Sheets("基本設定").Range("j2").Value
    r = "C:\Documents and Settings\Administrator\桌面\"
    n = a & "學年度" & b & "學期" & u & "年" & v & "班成績檔"
    Sheets("成績儲存").Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=r & n & ".xlsx", _
    FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
    ReadOnlyRecommended:=False, CreateBackup:=False
    ThisWorkbook.Close savechanges:=True
End Sub
也如預期般可以在桌面存成另一個新檔，但是問題來了，因為這個工作表內有vba程式語法，所以另存新檔後，便會出現問題，就是有些語法會超出範圍，想請教一下，在複製工作表時有無選項，可以不用複製到裡面的語法嗎？再次感謝！

GBKEE

回復 18# skyutm
副檔名 .xlsx 為2003以上的版本 存為無巨集的活頁簿 應該沒有你說的問題

如是2003版可試試看  如執行有錯誤 請看  http://gb.twbts.com/index.php?topic=751.8

1. Sub macor24()
   
2.     Dim a, b, u, v, r, n As String, xlVbc As Object
   
3.     a = Sheets("基本設定").Range("a6").Value
   
4.     b = Sheets("基本設定").Range("a8").Value
   
5.     u = Sheets("基本設定").Range("j1").Value
   
6.     v = Sheets("基本設定").Range("j2").Value
   
7.     r = "C:\Documents and Settings\Administrator\桌面\"
   
8.     n = a & "學年度" & b & "學期" & u & "年" & v & "班成績檔"
   
9.     Sheets("成績儲存").Copy
   
10.     Sheets(1).Copy
    
11.     Application.DisplayAlerts = False
    
12.     With ActiveWorkbook
    
13.         For Each xlVbc In .VBProject.VBComponents
    
14.             xlVbc.CodeModule.DeleteLines 1, xlVbc.CodeModule.CountOfLines
    
15.         Next
    
16.         .SaveAs Filename:=r & n & ".xls"
    
17.     End With
    
18.     ThisWorkbook.Close savechanges:=True
    
19. End Sub

複製代碼

skyutm

回復 19# GBKEE
版大您好！百忙之中又打擾了。您給的語法執行之後，還是會有語法在（所以會產生錯誤），而另外一個舊網頁所談的刪除工作表的巨集語法，在vba好像不能使用，最後小弟繞了一條遠路。就是：
1.先新增一新工作表
2.複製要複製的工作表
3.貼上時使用有條件的貼上選項（這樣就不上複製到工作表內的語法了）
PasteSpecial Paste:=xlPasteValues
PasteSpecial Paste:=xlPasteFormats
4.然後就是之前的語法
全部是
Sub macor24()
    '解除保護「成績儲存」表格↓'
    Sheets("成績儲存").Unprotect Password:="6323"
    ActiveWorkbook.Unprotect Password:="6323"
    '解除保護「成績儲存」表格↑'
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("成績儲存").Activate
    Sheets("成績儲存").Cells.Copy
    Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteValues
    Sheets("成績儲存").Activate
    Sheets("成績儲存").Cells.Copy
    Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteFormats
    Dim a, b, u, v, r, n As String
    a = Sheets("基本設定").Range("a6").Value
    b = Sheets("基本設定").Range("a8").Value
    u = Sheets("基本設定").Range("j1").Value
    v = Sheets("基本設定").Range("j2").Value
    r = "C:\Documents and Settings\Administrator\桌面\"
    n = a & "學年度" & b & "學期" & u & "年" & v & "班成績檔"
    Sheets(Sheets.Count).Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=r & n & ".xls", _
    FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
    ReadOnlyRecommended:=False, CreateBackup:=False
    Workbooks(1).Activate
    Sheets(Sheets.Count).Delete
    '保護「成績儲存」表格↓'
    Sheets("成績儲存").Activate
    ActiveSheet.EnableSelection = xlUnlockedCells
    Sheets("成績儲存").Protect Password:="6323"
    ActiveWorkbook.Protect Password:="6323"
    '保護「成績儲存」表格↑'
    Workbooks(2).Activate
    ActiveWorkbook.Close savechanges:=True
End Sub
（抱歉！不是班門弄斧啦，想說以後有人需要，可以參考一下。）