12
返回列表 上一主題 發帖

[發問] Excel抓取多筆資料

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
1# 跳轉到 »
發表於 2023-6-26 08:30 | 顯示全部帖子
本帖最後由 Andy2483 於 2023-6-26 08:35 編輯

回復 1# cowww


    謝謝前輩發表此主題與範例
後學建議
1.以註解方式呈現 後續的異動,如下圖




PS:如果長官使用的螢幕夠大也可分割畫面呈現
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
2#
發表於 2023-6-26 15:46 | 顯示全部帖子
回復 3# cowww


    謝謝前輩回復
後學藉此帖練習陣列.字典與註解,學習方案如下,請前輩參考

執行結果:



Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Brr, Crr, Z, i&, T$, PH$, FN$, xB As Workbook, Sh As Worksheet
Set Z = CreateObject("Scripting.Dictionary")
PH = ThisWorkbook.Path: FN = "異動表排序.xlsm"
On Error Resume Next
Set xB = Workbooks(FN): Set Sh = xB.Sheets("異動表排序")
Brr = Range(Sh.[E1], Sh.[A65536].End(3))
On Error GoTo 0
If xB Is Nothing Then
   Set xB = Workbooks.Open(PH & "\" & FN)
   Brr = Range([異動表排序!E1], [異動表排序!A65536].End(3))
   xB.Close 0
End If
For i = 1 To UBound(Brr)
   T = Brr(i, 2): If T = "" Then GoTo i00
   If Z(T) = "" Then
      Z(T) = Brr(i, 3) & " █ " & Brr(i, 4)
      Else
         Z(T) = Z(T) & vbLf & Brr(i, 3) & " █ " & Brr(i, 4)
   End If
i00: Next
Brr = Range([專案!D1], [專案!D65536].End(3))
[D:D].ClearComments
For i = 1 To UBound(Brr)
   If Brr(i, 1) = "" Or Z(Brr(i, 1) & "") = "" Then GoTo i01
   Cells(i, 4).AddComment
   Cells(i, 4).Comment.Text Text:=Z(Brr(i, 1) & "")
   Cells(i, 4).Comment.Shape.TextFrame.Characters.Font.Size = 16
   Cells(i, 4).Comment.Shape.DrawingObject.AutoSize = True
i01: Next
Set Z = Nothing: Erase Brr: Set xB = Nothing: Set Sh = Nothing
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
3#
發表於 2023-6-27 08:00 | 顯示全部帖子
謝謝論壇,謝謝各位前輩
後學藉此帖複習昨天的學習方案,方案學習心得註解如下,請各位前輩指教

Option Explicit
Sub TEST()
Application.ScreenUpdating = False
'↑令螢幕暫不隨著程序做變化
Dim Brr, Z, i&, T$, PH$, FN$, xB As Workbook, Sh As Worksheet
'↑宣告變數($是字串變數,&是長整數,沒有符號的是通用型變數)
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是 字典
PH = ThisWorkbook.Path: FN = "異動表排序.xlsm"
'↑令PH變數是 本檔資料夾位址,令FN變數是 指定檔名(資料表)
On Error Resume Next
'↑令程序暫遇到錯誤就繼續執行下個程序,不要停下來排錯
Set xB = Workbooks(FN): Set Sh = xB.Sheets("異動表排序")
'↑令xB變數是 活頁簿("異動表排序.xlsm"),令Sh變數是其工作表
Brr = Range(Sh.[E1], Sh.[A65536].End(3))
'↑令Brr變數是 二維陣列,以A~E欄儲存格值帶入陣列中
On Error GoTo 0
'↑令程序恢復遇到錯誤就停下來排錯
'這段不排錯的程序是為了 "異動表排序.xlsm"被開啟的情境下,
'讓Brr可以裝進陣列值
'如果檔案沒有被開啟的情況,程序就會跳過這些程序,繼續下行
If xB Is Nothing Then
'↑如果xB變數還沒有裝入活頁簿("異動表排序.xlsm")??
   Set xB = Workbooks.Open(PH & "\" & FN)
   '↑令開啟指定路徑下的檔案,並令xB變數是此活頁簿
   Brr = Range([異動表排序!E1], [異動表排序!A65536].End(3))
   '↑令Brr變數是 二維陣列,以A~E欄儲存格值帶入陣列中
   xB.Close 0
   '↑令活頁簿不存檔關閉
End If
For i = 1 To UBound(Brr)
'↑設順迴圈
   T = Brr(i, 2): If T = "" Then GoTo i00
   '↑令T變數是 迴圈列第2欄Brr陣列值,如果T變數是空的!
   '是就跳到標示i00位置繼續執行
   If Z(T) = "" Then
   '↑如果以T變數查Z字典得item值是空字元?
      Z(T) = Brr(i, 3) & " █ " & Brr(i, 4)
      '↑是就令在Z字典裡的T變數key 的item換成新字串
      '新字串:迴圈列第3欄Brr陣列值連接 " █ "再連接 迴圈列第4欄Brr陣列值,
      '成為新字串,放回Z字典裡
      Else
         Z(T) = Z(T) & vbLf & Brr(i, 3) & " █ " & Brr(i, 4)
         '↑否則(T變數key 的item值已經有字串!)
         '令item連接換行再連接 迴圈列第3欄Brr陣列值連接 " █ "再連接
         '迴圈列第4欄Brr陣列值成為新字串,放回Z字典裡
   End If
i00: Next
Brr = Range([專案!D1], [專案!D65536].End(3))
'↑令Brr變數換裝結果表的D欄儲存格值,依然是 二維陣列
'PS:Brr宣告是通用型變數,可以任意=換裝資料 或Set Brr = 物件
[D:D].ClearComments
'↑令D欄的註解清除
For i = 1 To UBound(Brr)
'↑設順迴圈
   If Brr(i, 1) = "" Or Z(Brr(i, 1) & "") = "" Then GoTo i01
   '↑排除空格或字典裡item是空字元的項目,跳到標示i01位置繼續執行
   Cells(i, 4).AddComment
   '↑令i迴圈數列D欄儲存格插入註解
   Cells(i, 4).Comment.Text Text:=Z(Brr(i, 1) & "")
   '↑令i迴圈數列D欄儲存格的註解文字是 迴圈Brr陣列值查Z字典得item值
   Cells(i, 4).Comment.Shape.TextFrame.Characters.Font.Size = 16
   '↑令i迴圈數列D欄儲存格的註解文字大小為 16
   Cells(i, 4).Comment.Shape.DrawingObject.AutoSize = True
   '↑令i迴圈數列D欄儲存格的註解框自動縮放
i01: Next
Set Z = Nothing: Erase Brr: Set xB = Nothing: Set Sh = Nothing
'↑令釋放變數
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
4#
發表於 2023-6-27 08:27 | 顯示全部帖子
回復 7# cowww


    都註解了! 請自己試改看看囉,一起學習
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
5#
發表於 2023-6-27 09:15 | 顯示全部帖子
回復 9# cowww

求救也沒用
遠水救不了
自己的環境自己才能試,多試幾次吧
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
6#
發表於 2023-6-27 09:41 | 顯示全部帖子
回復 7# cowww


    是這種樣式嗎?

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
7#
發表於 2023-6-27 09:55 | 顯示全部帖子
本帖最後由 Andy2483 於 2023-6-27 09:59 編輯

回復 13# cowww


   
加個星號


用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
8#
發表於 2023-6-27 10:40 | 顯示全部帖子
回復 15# cowww

檢查簡化了一下,學習方案如下,請前輩參考

    Option Explicit
Sub TEST_1()
Application.ScreenUpdating = False
Dim Brr, Z, A, B, i&, R&, T$, T1$, PH$, FN$, xB As Workbook, Sh As Worksheet
Set Z = CreateObject("Scripting.Dictionary")
PH = ThisWorkbook.Path: FN = "異動表排序.xlsm"
On Error Resume Next
Set xB = Workbooks(FN): Set Sh = xB.Sheets("異動表排序")
Brr = Range(Sh.[E1], Sh.[A65536].End(3))
On Error GoTo 0
If xB Is Nothing Then
   Set xB = Workbooks.Open(PH & "\" & FN)
   Brr = Range([異動表排序!E1], [異動表排序!A65536].End(3))
   xB.Close 0
End If
For i = 1 To UBound(Brr)
   T = Brr(i, 2): If T = "" Then GoTo i00
   T1 = Brr(i, 1): A = Z(T1)
   If A = "" Then
      For R = i To UBound(Brr)
         If T1 <> Brr(R, 1) Then Z(T1) = A: Exit For
         B = "   " & Brr(R, 2) & " " & Brr(R, 3) & " " & Brr(R, 4) & " " & Brr(R, 5)
         If i = R Then A = Brr(R, 1) & vbLf & B Else A = A & vbLf & B
      Next
   End If
   If Z(T) = "" Then
      Z(T) = Z(T1)
      ElseIf InStr(Z(T), Z(T1)) = 0 Then
         Z(T) = Z(T) & vbLf & vbLf & Z(T1)
   End If
i00: Next
Brr = Range([專案!D1], [專案!D65536].End(3))
[V:V].ClearComments
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): If T1 = "" Or Z(T1) = "" Then GoTo i01
   With Cells(i, 22).AddComment
      .Text Text:=Replace(Z(T1), "   " & T1, "★" & T1)
      .Shape.TextFrame.Characters.Font.Size = 16
      .Shape.DrawingObject.AutoSize = True
   End With
i01: Next
Set Z = Nothing: Erase Brr: Set xB = Nothing: Set Sh = Nothing
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
9#
發表於 2023-7-5 07:39 | 顯示全部帖子
回復 18# cowww


    謝謝前輩回復
查看了示意圖已經與原範例需求結果不同,請上傳新範例

不同處:
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1429 
主題
40 
精華
0 
積分
1453 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-5-18 
10#
發表於 2023-7-5 07:47 | 顯示全部帖子
回復 19# qaqa3296

"異動表排序"會少最後一筆資料，該如何修正，我看迴圈都有跑滿，但是會少最後一筆(沒有任何備註)

    謝謝前輩一起學習,待cowww上傳新情境範例後,後學再試解看看,屆時再一起討論學習
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

        靜思自在 : 手心向下是助人，手心向上是求人；助人快樂，求人痛苦。
12
返回列表 上一主題