[µo°Ý] ½Ð°Ý¦p¦ó¦bexcel¸Ì­±§Q¥Î¿é¤J¹Ï¦Wvba¶K¹Ï

xlarge16803

¥Ñ©ó¸ê®Æ¼Æ¶q¦³¤@¤d¦hµ§©Ò¥H·Q°_À³¸Ó¥i¥H¥Î¥¨¶°¤è¦¡°õ¦æ¡A
§Q¥Î«e­±¿é¤Jªº½s¸¹¼g¤@­Ó¥¨¶°¥h¶}±Òc:/my picture/001¡A¨Ã¶K¤W³o­Ó¹ÏÀÉ
¦ý¬O§Ú¹ï¥¨¶°ÁÙ°±¦b¿ý»s¶¥¬q©Ò¥H¤£ª¾¹D¸Ó«ç»ò°µ¡A½Ð°ª¤âÀ°¦£ÂP¡C·P¿E¤£ºÉ

¡@¢°¡DA¢²¿é¤J¹Ï¦W (¨Ò¦p¿é¤J1-15 ´N¥X²{½s¸¹1-15ªº¹Ï)¡A
            ¨Ì§Ç¦b(B3¡DC3¡DD3¡DE3¡DB4¡DC4¡DD4¡DE4.....B6¡DC6¡DD6)¥H¦¹Ãþ±À¶K¤J¹ÏÀÉ¡A
¡@¡@¡@ÀɦW¬°(1.jpg¡D2.jpg¡D3.jpg.¡D4.jpg......15.jpg)
¡@¢±¡D¹Ï¤ù¦Û°Ê½Õ¾ã»PÀx¦s®æ¬Û¦P¤j¤p¡C
¡@
Sub ¸ü¤J¹Ï¤ù()
¡@Dim MyRng As Range, xR As Range, uPath$, y&, xFile$
¡@Set MyRng = [A3]
¡@If [A3] = "" Then MsgBox "µL¹ÏÀɦWºÙ¡I": Exit Sub
¡@uPath = ThisWorkbook.Path & "c:/my picture/"
¡@If Dir(uPath, vbDirectory) = "" Then MsgBox "§ä¤£¨ì¹ÏÀɸê®Æ§¨¡I": Exit Sub
¡@ActiveSheet.Pictures.Delete
¡@Application.ScreenUpdating = False
¡@For Each xR In Union([B3], [C3], [D3], [E3])
¡@¡@¡@y = y + 1
¡@¡@¡@xFile = uPath & "\" & MyRng & "-" & y & ".JPG"
¡@¡@¡@If Dir(xFile) = "" Then GoTo 101
¡@¡@¡@With ActiveSheet
¡@¡@¡@¡@¡@.Pictures.Insert (xFile)
¡@¡@¡@With .Shapes(.Shapes.Count)
¡@¡@¡@¡@¡@.LockAspectRatio = msoFalse
¡@¡@¡@¡@¡@.Width = xR.Width
¡@¡@¡@¡@¡@.Height = xR.Height
¡@¡@¡@¡@¡@.Left = xR.Left
¡@¡@¡@¡@¡@.Top = xR.Top
¡@¡@¡@End With
¡@¡@¡@End With
¡@101: Next
¡@End Sub

GBKEE

¦^´_ 1# xlarge16803

1. Option Explicit
   
2. Sub ¸ü¤J¹Ï¤ù()
   
3.     Dim MyRng As Range, XR As Range, uPath$, y&, xFile$
   
4.     Set MyRng = [A3]
   
5.     If [A3] = "" Then MsgBox "µL¹ÏÀɦWºÙ¡I": Exit Sub
   
6.     'ThisWorkbook.Path ¶Ç¦^³o¬¡­¶Ã¯ÀɮצsÀɪº¸ô®| ¦p ="C:\"
   
7.     uPath = ThisWorkbook.Path & "c:/my picture/" ' =>"C:\c:/my picture/" ³o¬O¿ù»~ªº¸ô®|?
   
8.     '¬O³o¼Ë§a!!
   
9.     uPath = ThisWorkbook.Path '->= "c:/my picture" ¹ï¶Ü???
   
10.     If Dir(uPath, vbDirectory) = "" Then MsgBox "§ä¤£¨ì¹ÏÀɸê®Æ§¨¡I": Exit Sub
    
11.     ActiveSheet.Pictures.Delete
    
12.     Application.ScreenUpdating = False
    
13.     For Each XR In Union([B3], [C3], [D3], [E3])
    
14.         y = y + 1
    
15.         xFile = uPath & "\" & MyRng & "-" & y & ".JPG"
    
16.         If Dir(xFile) <> "" Then
    
17.             With ActiveSheet.Pictures.Insert(xFile)
    
18.             .ShapeRange.LockAspectRatio = msoFalse
    
19.             .Width = XR.Width
    
20.             .Height = XR.Height
    
21.             .Left = XR.Left
    
22.             .Top = XR.Top
    
23.             End With
    
24.         End If
    
25.     Next
    
26. End Sub

½Æ»s¥N½X

xlarge16803

·PÁ¤j¤j¸Ñµª
¤£·N«ä ¦A½Ð±Ð¤@¤U
§ï¦¨sheet1 A¢²¿é¤J¹Ï¦W (¨Ò¦p¿é¤J1-15 ´N¥X²{½s¸¹1-15ªº¹Ï) «ö¶K¹Ï¥¨¶°¶s
¶K¦bsheet2 ¨Ì§Ç¦b(B3¡DC3¡DD3¡DE3¡DB4¡DC4¡DD4¡DE4.....B6¡DC6¡DD6)¥H¦¹Ãþ±À¶K¤J¹ÏÀÉ

§ï¤§«á¤@°Ê¤]¤£°Ê ­n³o»ò§ï...

GBKEE

¦^´_ 3# xlarge16803
¨S¬ÝÀɮפε{¦¡½X,¦p¦ó·|ª¾¹D§A¿ù»~¦b­þ¸Ì.

xlarge16803

©êºp!!
ªþ¤Wµ{¦¡½X..
§Ú·Q¦b¤½¥q¥Î³o­Óµ{¦¡ ¸ô®|¹Ï¬O\\178.153.85\fast\«~½èºÞ²zG\ ¬O§_¤]¥i¥H§ì¹Ï
«D±`·PÁ¤j¤j ¸Ñµª
Sheets("Sheet1").Select
Sub ¸ü¤J¹Ï¤ù()
    Dim MyRng As Range, XR As Range, uPath$, y&, xFile$
    Set MyRng = [A3]
    If [A3] = "" Then MsgBox "µL¹ÏÀɦWºÙ¡I": Exit Sub
    'ThisWorkbook.Path ¶Ç¦^³o¬¡­¶Ã¯ÀɮצsÀɪº¸ô®| ¦p ="C:\"
    uPath = ThisWorkbook.Path & "c:/my picture/" ' =>"C:\c:/my picture/" ³o¬O¿ù»~ªº¸ô®|?
    '¬O³o¼Ë§a!!
    uPath = ThisWorkbook.Path '->= "c:/my picture" ¹ï¶Ü???
    If Dir(uPath, vbDirectory) = "" Then MsgBox "§ä¤£¨ì¹ÏÀɸê®Æ§¨¡I": Exit Sub
    ActiveSheet.P2ctures.Delete
    Sheets("Sheet1").Select
    Application.ScreenUpdating = False
    For Each XR In Union([B3], [C3], [D3], [E3])
        y = y + 1
        xFile = uPath & "\" & MyRng & "-" & y & ".JPG"
        If Dir(xFile) <> "" Then
            With ActiveSheet.Pictures.Insert(xFile)
            .ShapeRange.LockAspectRatio = msoFalse
            .Width = XR.Width
            .Height = XR.Height
            .Left = XR.Left
            .Top = XR.Top
            End With
        End If
    Next
End Sub