12
返回列表 上一主題 發帖

[發問] 關鍵字抓圖片

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
11# 跳轉到 »
發表於 2012-12-15 09:45 | 只看該作者
回復 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

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
12#
發表於 2012-12-15 11:19 | 只看該作者
回復  c_c_lai
幫我看一下
我想要在A欄B欄放位址
C欄為圖片檔名
D欄為顯示A的圖片
E欄顯示B的圖片
使 ...
whirlwind963 發表於 2012-12-15 09:45

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

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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
13#
發表於 2012-12-15 11:28 | 只看該作者
回復 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

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
14#
發表於 2012-12-16 10:33 | 只看該作者
回復 11# whirlwind963
回復 13# GBKEE
星期日無聊，便動筆修改了 GBKEE 大大的程式： (望不要介意)
  1. Option Explicit

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

TOP

        靜思自在 : 為自己找藉口的人永遠不會進步。
12
返回列表 上一主題