返回列表 上一主題 發帖

[發問] 關鍵字抓圖片

回復 9# c_c_lai
幫我看一下
我想要在A欄B欄放位址
C欄為圖片檔名
D欄為顯示A的圖片
E欄顯示B的圖片
使用FOR 迴圈
圖片會在D欄重疊
該怎麼改呢
     Option Explicit

    Sub Ex()
        Dim j As Integer, MyPath As String, MyFile As String, k, l

        For k = 1 To 2
           For l = 4 To 5
          j = 2
        While Cells(j, "C") <> "" 'C2為檔名
         MyPath = Cells(j, k)  'A2 B2為位址
            If UCase(Cells(j, "C")) Like "*W*" Then  '字串中有"ABCD"
               '  UCase 函數 傳回一個 Variant (String),所含為轉成大寫之字串。
                Cells(j, l).Select   'D2 E2為圖片
                On Error Resume Next
                MyFile = Dir(MyPath & "*" & Cells(j, "C") & "*.*")       '  C2 = "ABCD" ->"1AABCD.png"

                If MyFile <> "" Then
                    With ActiveSheet.Pictures.Insert(MyPath & MyFile)
                        '  .ShapeRange.LockAspectRatio = msoTrue
                        '  在調整圖案大小時,可以分別地調整圖案的長度和寬度
                        .ShapeRange.LockAspectRatio = msoFalse
                        .ShapeRange.Height = 100#
                        .ShapeRange.Width = 100#
                        .ShapeRange.Rotation = 0#
                        .Placement = xlMoveAndSize
                        .PrintObject = True
                    End With
                End If
            End If
            j = j + 1
        Wend
        Range("C2").Select
        Next
        Next
    End Sub

TOP

回復  c_c_lai
幫我看一下
我想要在A欄B欄放位址
C欄為圖片檔名
D欄為顯示A的圖片
E欄顯示B的圖片
使 ...
whirlwind963 發表於 2012-12-15 09:45

你的迴圈處理地非常奇怪,

  1. For k = 1 To 2
  2.         For l = 4 To 5
  3.                j = 2
  4.               While Cells(j, "C") <> ""
  5.                       '  ......
  6.                       j = j + 1
  7.               Wend      '    每次迴圈都從頭跑一次
  8.         Next
  9. Next
複製代碼
你把此檔案上傳,我實地演練一次。

TOP

回復 11# whirlwind963
  1. Option Explicit
  2. Sub Ex()
  3.     Dim j As Integer, MyPath As String, MyFile As String, k, L
  4.     For k = 1 To 2                          'A,B欄
  5.         For L = 4 To 5                      'D,E欄
  6.             j = 2
  7.             While Cells(j, "C") <> ""       'C欄為檔名
  8.                 MyPath = Cells(j, k)        'A欄,B欄為位址
  9.                 If UCase(Cells(j, "C")) Like "*W*" Then  '字串中有"ABCD"
  10.                     On Error Resume Next
  11.                     MyFile = Dir(MyPath & "*" & Cells(j, "C") & "*.*")       '  C2 = "ABCD" ->"1AABCD.png"
  12.                     If MyFile <> "" Then
  13.                         Cells(j, L).Select   'D,E欄
  14.                         With ActiveSheet.Pictures.Insert(MyPath & MyFile)
  15.                             .ShapeRange.LockAspectRatio = msoFalse
  16.                             .ShapeRange.Height = 100#
  17.                             .ShapeRange.Width = 100#
  18.                             .ShapeRange.Rotation = 0#
  19.                             .Placement = xlMoveAndSize
  20.                             .PrintObject = True
  21.                         End With
  22.                     End If
  23.                 End If
  24.                 j = j + 1
  25.             Wend
  26.             Range("C2").Select
  27.         Next
  28.     Next
  29. End Sub
複製代碼

TOP

回復 11# whirlwind963
回復 13# GBKEE
星期日無聊,便動筆修改了 GBKEE 大大的程式: (望不要介意)
  1. Option Explicit

  2. Sub Ex2()
  3.     Dim j As Integer, k As Integer, MyPath As String, MyFile As String
  4.    
  5.     Application.ScreenUpdating = False
  6.    
  7.     ActiveSheet.Pictures.Delete
  8.     j = 2
  9.     While Cells(j, "C") <> ""                           '  C欄為檔名
  10.         For k = 1 To 2
  11.             MyPath = Cells(j, k)                       
  12.            '  A欄,B欄為位址 例如: D:\My Pictures\15\ 、及 E:\Amazing Pictures\16\ 等等。
  13.             If UCase(Cells(j, "C")) Like "*ABCD*" Then  ' 字串中有"ABCD"
  14.                 On Error Resume Next
  15.                 MyFile = Dir(MyPath & "*" & Cells(j, "C") & "*.*")
  16.                 If MyFile <> "" Then
  17.                     Cells(j, IIf(k = 1, 4, 5)).Select   ' D,E欄
  18.                     With ActiveSheet.Pictures.Insert(MyPath & MyFile)
  19.                         .ShapeRange.LockAspectRatio = msoFalse
  20.                         .ShapeRange.Height = 100#
  21.                         .ShapeRange.Width = 100#
  22.                         .ShapeRange.Rotation = 0#
  23.                         .Placement = xlMoveAndSize
  24.                         .PrintObject = True
  25.                     End With
  26.                 End If
  27.             End If
  28.         Next
  29.         j = j + 1
  30.     Wend
  31.     Range("C2").Select
  32.     Application.ScreenUpdating = True
  33. End Sub
複製代碼

TOP

        靜思自在 : 並非有錢魷是快樂,問心無愧心最安。
返回列表 上一主題