12
返回列表 上一主題 發帖

[發問] 關鍵字抓圖片

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2012-12-11 23:18 | 只看該作者

[發問] 關鍵字抓圖片

請問一個資料夾裡面有很多的圖片
我從C2開始輸入檔名
但我只知道關鍵字
例如:ABCD123456  我只輸入ABCD
這樣也能抓到圖片
下面的程式碼哪裡有錯嗎
麻煩各位~幫我看一下
Sub Macro1()
    j = 2
    MyPath = "C:\My Pictures\"
    MyFile = Dir(MyPath & Cells(j, "C") & "*.jpg")
    While Cells(j, "C") <> ""
        NN = Cells(j, "C")
        Cells(j, "D").Select
        On Error Resume Next
        ActiveSheet.Pictures.Insert(MyFile).Select
        Selection.ShapeRange.LockAspectRatio = msoTrue
        Selection.ShapeRange.Height = 100#
        Selection.ShapeRange.Width = 100#
        Selection.ShapeRange.Rotation = 0#
        With Selection
        .Placement = xlMoveAndSize
        .PrintObject = True
        End With
    j = j + 1
    Wend
    Range("C2").Select
End Sub
收藏 分享

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

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 
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

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
10#
發表於 2012-12-12 20:49 | 只看該作者
回復 8# whirlwind963
  1. Option Explicit
  2. Sub Ex() '傳回資料夾中符合[C2] 的檔案
  3.     Dim j As Integer, MyPath As String, xlJpg As String
  4.     j = 2
  5.     ActiveSheet.Pictures.Delete
  6.     MyPath = "C:\My Pictures\"
  7.     'Dir 函數 傳回一個 String ，用以表示合乎條件、檔案屬性、磁碟標記的一個檔案名稱、或目錄、檔案夾名稱。
  8.     xlJpg = Dir(MyPath & [C2] & "*.JPG")       '開頭= [C2]的字串
  9.    'xlJpg = Dir(MyPath & "*" & [C2] & "*.JPG")  '包含[C2]的字串
  10.    'xlJpg = Dir(MyPath & "*" & [C2] & ".JPG")   '包含[C2]的字串在尾端
  11.     Do While xlJpg <> ""
  12.        Cells(j, "D").Select
  13.         With ActiveSheet.Pictures.Insert(MyPath & xlJpg)
  14.             '  .ShapeRange.LockAspectRatio = msoTrue
  15.             '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
  16.             .ShapeRange.LockAspectRatio = msoFalse
  17.             .ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
  18.             .ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
  19.             .ShapeRange.Rotation = 0#
  20.             .Placement = xlMoveAndSize
  21.             .PrintObject = True
  22.         End With
  23.         j = j + 1
  24.         xlJpg = Dir
  25.     Loop
  26.     Range("C2").Select
  27. End Sub
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
9#
發表於 2012-12-12 15:59 | 只看該作者
回復 8# whirlwind963
  1. Option Explicit

  3. Sub Ex()
  4.     Dim j As Integer, MyPath As String, MyFile As String
  5.    
  6.     j = 2
  7.     MyPath = "C:\My Pictures\"
  8.    
  9.     While Cells(j, "C") <> ""
  10.         If UCase(Cells(j, "C")) Like "*ABCD*" Then  '字串中有"ABCD"
  11.            '  UCase 函數 傳回一個 Variant (String)，所含為轉成大寫之字串。
  12.             Cells(j, "D").Select
  13.             
  14.             Selection.RowHeight = 100
  15.             Selection.ColumnWidth = 25
  16.             
  17.             On Error Resume Next
  18.             MyFile = Dir(MyPath & "*" & Cells(j, "C") & "*.*")       '  C2 = "ABCD" ->"1AABCD.png"

  20.             If MyFile <> "" Then
  21.                 With ActiveSheet.Pictures.Insert(MyPath & MyFile)
  22.                     '  .ShapeRange.LockAspectRatio = msoTrue
  23.                     '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
  24.                     .ShapeRange.LockAspectRatio = msoFalse
  25.                     .ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
  26.                     .ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
  27.                     .ShapeRange.Rotation = 0#
  28.                     .Placement = xlMoveAndSize
  29.                     .PrintObject = True
  30.                 End With
  31.             End If
  32.         End If
  33.         j = j + 1
  34.     Wend
  35.     Range("C2").Select
  36. End Sub
複製代碼

TOP

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
8#
發表於 2012-12-12 14:09 | 只看該作者
回復 6# GBKEE
不好意思
我想要的正好是相反的
假設檔名為ABCD123456.jpg
我在C2輸入ABCD
D2能顯示ABCD123456.JPG的圖片

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
7#
發表於 2012-12-12 12:34 | 只看該作者
回復 6# GBKEE
我已經修正完成，如圖，謝謝您！
  1. Option Explicit
  2. Sub Ex()
  3.     Dim j As Integer, MyPath As String
  4.    
  5.     j = 2
  6.     MyPath = "C:\My Pictures\"
  7.    
  8.     While Cells(j, "C") <> ""
  9.         If UCase(Cells(j, "C")) Like "*ABCD*" Then  '字串中有"ABCD"
  10.            'UCase 函數 傳回一個 Variant (String)，所含為轉成大寫之字串。
  11.             Cells(j, "D").Select
  12.             
  13.             Selection.RowHeight = 100
  14.             Selection.ColumnWidth = 25
  15.             
  16.             On Error Resume Next
  17.             If Dir(MyPath & Cells(j, "C")) <> "" Then
  18.                 With ActiveSheet.Pictures.Insert(MyPath & Cells(j, "C"))
  19.                     '  .ShapeRange.LockAspectRatio = msoTrue
  20.                     '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
  21.                     .ShapeRange.LockAspectRatio = msoFalse
  22.                     .ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
  23.                     .ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
  24.                     .ShapeRange.Rotation = 0#
  25.                     .Placement = xlMoveAndSize
  26.                     .PrintObject = True
  27.                 End With
  28.             End If
  29.         End If
  30.         j = j + 1
  31.     Wend
  32.     Range("C2").Select
  33. End Sub
複製代碼

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2012-12-12 11:27 | 只看該作者
回復 5# c_c_lai
2# 有誤 已更正
  1. Option Explicit
  2. Sub Ex()
  3.     Dim j As Integer, MyPath As String
  4.     j = 2
  5.     MyPath = "D:\My Pictures\"
  6.     While Cells(j, "C") <> ""
  7.         If UCase(Cells(j, "C")) Like "*ABCD*" Then  '字串中有"ABCD"
  8.            'UCase 函數 傳回一個 Variant (String)，所含為轉成大寫之字串。
  9.             Cells(j, "D").Select
  10.             Selection.RowHeight = 82
  11.            If Dir(MyPath & Cells(j, "C")) <> "" Then
  12.                 With ActiveSheet.Pictures.Insert(MyPath & Cells(j, "C"))
  13.                     '  .ShapeRange.LockAspectRatio = msoTrue
  14.                     '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
  15.                     .ShapeRange.LockAspectRatio = msoFalse
  16.                     .ShapeRange.Height = IIf(.ShapeRange.Height > 100, 100, .ShapeRange.Height)
  17.                     .ShapeRange.Width = IIf(.ShapeRange.Width > 200, 200, .ShapeRange.Width)
  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. End Sub
複製代碼

TOP

        靜思自在 : 一個人不怕錯，就怕不改過，改過並不難。
12
返回列表 上一主題