麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 擷取報表中所需資料 [打印本頁]

作者: asus103 時間: 2010-12-28 10:00 標題: 擷取報表中所需資料

本帖最後由 asus103 於 2011-1-3 12:07 編輯

您好：
我是VBA初學者，現在需要把一份雜亂的原始報表，整理成所需型式的工作表(如附件)
請問除了土法煉鋼(出錯率較高)以外，能否有自動處理的方式，也當作我學習上的一個範本。
我想這是一個浩大的工程。
感謝您附註：
1.各班可能會切成兩部分
2.各班選修科目也不相同
3.各班人數可能會改變
4.所需排列方式如SHEET4

作者: GBKEE 時間: 2010-12-28 14:13

回復 1# asus103

Option Explicit
Sub Ex()
Dim D(1) As Object, F As Range, MyClass$, F_Address$, Rng As Range, C, R, D_Key$, ARng As Range
Set D(0) = CreateObject("SCRIPTING.DICTIONARY")
Set D(1) = CreateObject("SCRIPTING.DICTIONARY")
With Sheets("Sheet1")
Set F = .Range("B:B").Find(what:="學　號", After:=.[b1], Lookat:=xlWhole)
If Not F Is Nothing Then
F_Address = F.Address
Do
Set Rng = .Range(F, F.End(xlToRight).End(xlDown))
MyClass = F.Offset(-2)
For Each C In Rng.Columns(1).Cells
If IsNumeric(C) Then
D_Key = C & "," & C(1, 2) & "," & MyClass & "," & C(1, 3)
D(0)(D_Key) = ""
For R = 4 To Rng.Columns.Count
If Rng(1, R) <> "" Then D(1)(D_Key & Rng(1, R)) = .Cells(C.Row, Rng(1, R).Column)
Next
End If
Next
Set F = .Range("B:B").FindNext(F)
Loop While F_Address <> F.Address
With Sheets("Sheet4")
.UsedRange.Offset(1).Clear
For Each R In D(0).KEYS
Set ARng = .Range("A" & Rows.Count).End(xlUp).Offset(1)
ARng.Resize(, 4) = Split(R, ",")
For C = 5 To .[A1].End(xlToRight).Column
If .Cells(1, C) <> "" Then ARng(1, C) = D(1)(R & .Cells(1, C))
Next
Next
End With
End If
End With
End Sub

複製代碼

作者: asus103 時間: 2010-12-28 17:32

GBKEE：
非常感謝您!!!!
我現在馬上處理，先感謝您的費心

作者: asus103 時間: 2010-12-28 19:10

回復 2# GBKEE
再一次感謝您
現在基本資料進來了
只是自己程度還不夠，尚無法完全看懂，我會再加油看懂它

那成績部分我若是用vlookup處理會遇到兩個問題
1.原資料並非完整區塊，中間有許多空白
2.各班及科目位置並不相同
請問有方法把成績轉移過來嗎?
謝謝

作者: GBKEE 時間: 2010-12-28 20:09

回復 4# asus103
附檔上來看看

作者: asus103 時間: 2010-12-28 20:31

回復 5# GBKEE

GBKEE您好
原來的檔案中，即有成績的部分
只是各班(如5班以後)選修科目並不相同，
所以我無法自動判別取出

另，我的權限無法看到我自己的附檔
若檔案有問題煩請再告知
謝謝!!!

作者: GBKEE 時間: 2010-12-28 21:12

回復 6# asus103
如圖只要資料的B欄內 [班級] 在 [學號] 的上2列程式應可應付的

[attach]4244[/attach]

作者: Hsieh 時間: 2010-12-28 23:32

回復 3# asus103

Sub Ex()
Dim A As Range, Ar(), C, d As Object, d1 As Object, d2 As Object, r&, MyClass$, Ky, s%, i%
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
For Each A In .Range(.[B1], .Cells(.Cells.Rows.Count, 2).End(xlUp))
If A Like "*班" Then MyClass = A.Value
If Replace(A.Value, "　", "") = "學號" Then Ar = .Range(A, A.End(xlToRight)).Value
If Val(A.Value) <> 0 And InStr(A, "-") = 0 Then
s = 0
For Each C In Ar
If C <> "" Then d1(C) = ""
If C = "姓名" Then d1("班級") = "": d(A & "班級") = MyClass
d2(A.Value) = ""
d(A & C) = A.Offset(, s).Value
s = s + 1
Next
End If
Next
End With
With Sheets("Sheet4")
.Cells = ""
r = 2
.[A1].Resize(, d1.Count) = d1.KEYS
For Each Ky In d2.KEYS
For i = 1 To d1.Count
.Cells(r, i) = d(Ky & .Cells(1, i))
Next
r = r + 1
Next
End With
End Sub

複製代碼

作者: asus103 時間: 2010-12-29 08:28

本帖最後由 asus103 於 2010-12-30 12:06 編輯

衷心感謝兩位版主的鼎力協助
我原以為恐怕需要很長的程式碼才能解決的
兩位版主化繁為簡的功力真令我佩服，而且是在這麼短的時間內
感激阿!!
我先使用了，之後我會努力看懂並學習的

尚有2個小問題請教：
1.若是把班級欄改為純數字，是否是手動即可
2.若想在未選修的位置上填上"-1"，那應該在哪一行加上些甚麼?
謝謝

作者: asus103 時間: 2010-12-30 12:08

回復 8# Hsieh
Hsieh大大您好
衷心感謝您的幫助

尚有2個小問題請教：
1.若是把班級欄改為純數字，是否是手動即可
2.若想在未選修的位置上填上"-1"，那應該在哪一行加上些甚麼?
謝謝

作者: Hsieh 時間: 2010-12-30 13:16

回復 10# asus103
程式提取的學號已經是數字了

Sub Ex()
Dim A As Range, Ar(), C, d As Object, d1 As Object, d2 As Object, r&, MyClass$, Ky, s%, i%
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
For Each A In .Range(.[B1], .Cells(.Cells.Rows.Count, 2).End(xlUp))
If A Like "*班" Then MyClass = A.Value
If Replace(A.Value, "　", "") = "學號" Then Ar = .Range(A, A.End(xlToRight)).Value
If Val(A.Value) <> 0 And InStr(A, "-") = 0 Then
s = 0
For Each C In Ar
If C <> "" Then d1(C) = ""
If C = "姓名" Then d1("班級") = "": d(A & "班級") = MyClass
d2(A.Value) = ""
d(A & C) = A.Offset(, s).Value
s = s + 1
Next
End If
Next
End With
With Sheets("Sheet4")
.Cells = ""
r = 2
.[A1].Resize(, d1.Count) = d1.KEYS
For Each Ky In d2.KEYS
For i = 1 To d1.Count
.Cells(r, i) = IIf(d(Ky & .Cells(1, i)) = "", -1, d(Ky & .Cells(1, i)))
Next
r = r + 1
Next
End With
End Sub

複製代碼

作者: asus103 時間: 2010-12-30 14:14

本帖最後由 asus103 於 2010-12-30 14:27 編輯

回復 11# Hsieh
對不起
是我沒有說清楚
是班級名稱，如三年二班改為302....

還有另外一個小問題
原始資料中若是"姓名"不是"姓名"(如B7中是"姓名"時，(中間有空白))
浪費您許多寶貴的時間，
只能在一次跟您說感謝
謝謝您

作者: Hsieh 時間: 2010-12-30 15:34

回復 12# asus103

Sub Ex()
Dim A As Range, Ar(), C, d As Object, d1 As Object, d2 As Object, r&, MyClass$, Ky, s%, i%
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
For Each A In .Range(.[B1], .Cells(.Cells.Rows.Count, 2).End(xlUp))
If A Like "*班" Then MyClass = A.Value
If Replace(A.Value, "　", "") = "學號" Then Ar = .Range(A, A.End(xlToRight)).Value
If Val(A.Value) <> 0 And InStr(A, "-") = 0 Then
s = 0
For Each C In Ar
If C <> "" Then d1(C) = ""
If C = "姓名" Then d1("班級") = "": d(A & "班級") = Replace(Replace(Replace(Replace(Replace(Replace(MyClass, "高", ""), "年", ""), "班", ""), "三", 3), "二", 2), "一", 1)
d2(A.Value) = ""
d(A & C) = IIf(s > 5, "", "'") & A.Offset(, s).Text
s = s + 1
Next
End If
Next
End With
With Sheets("Sheet4")
.Cells = ""
r = 2
.[A1].Resize(, d1.Count) = d1.KEYS
For Each Ky In d2.KEYS
For i = 1 To d1.Count
.Cells(r, i) = IIf(d(Ky & .Cells(1, i)) = "", -1, d(Ky & .Cells(1, i)))
Next
r = r + 1
Next
End With
End Sub

複製代碼

作者: asus103 時間: 2010-12-30 16:03

回復 13# Hsieh

全目標達成!!!!
非常地感謝您

附註:
有一個好玩的現象我會去研究
輸出的成績中，前三個是文字格式，之後是數字格式

再次感激
從這之間，我也學到好多，更明白"不足的更多"

作者: Hsieh 時間: 2010-12-30 16:21

改這行
d(A & C) = IIf(s > 2, "", "'") & A.Offset(, s).Text

作者: asus103 時間: 2010-12-30 16:44

回復 15# Hsieh
完全完美狀態!!!!!!您真是神人啊!!!!
我會以此為目標努力的!!
再一次感謝!!!

作者: asus103 時間: 2011-1-3 11:54

回復 13# Hsieh

Hsieh大大您好：
感謝您的熱心協助，工作上的問題已經OK
但基於想要把VBA學好的心情，關於這個程式的巧妙之處，是否可以繼續請教您
這幾天我先看了一本VBA入門的書
也詳細看了您發表的一些文章，如"Dictionary物件的認識與應用"、"VBA的寫作技巧與增進效能"、"學習 Excel VBA的一些基本概念"等，獲益良多
但此程式中的一些程式碼我還是看不懂
如：
For Each C In Ar
      If C <> "" Then d1(C) = ""
      If C = "姓　名" Then d1("班級") = "": d(A & "班級") = Replace(Replace(Replace(Replace(Replace(Replace(MyClass, "高", ""), "年", ""), "班", ""), "三", 3), "二", 2), "一", 1)
      d2(A.Value) = ""
      d(A & C) = IIf(s > 20, "", "'") & A.Offset(, s).Text
      '改變 s 可改變成績以文字或數字格式
      s = s + 1
   Next
這段中是如何將資料指定進入d、d1、d2這三個Dictionary物件的呢?
執行完d1(C) = ""後，d1的變數內容中竟然就出現count=1、Item1="學號"？真是太神奇了
"d1("班級") = "": d(A & "班級") ="的語法是甚麼？我想他是為了把班級這個ITEM指定進d1的第三項，但他是怎麼辦到的呢？

不好意思，小弟愚昧尚有許多不明之處，
期待您的相助之後，繼續探索VBA的世界

作者: Hsieh 時間: 2011-1-3 12:17

回復 17# asus103

http://forum.twbts.com/thread-20-1-1.html
先對該物件的屬性理解後再繼續討論

作者: asus103 時間: 2011-1-3 13:20

本帖最後由 asus103 於 2011-1-3 14:14 編輯

回復 18# Hsieh
您好：
這篇內容，我有印下來，讀了好幾次，可能是我沒有掌握到重點
把資料加入 Dictionary物件的語法：dictionary_object.Add index, content
可是您在程式中用的是『d1(C) = ""』OR『d2(A.Value) = ""』結果在"區域變數"中竟然就出現count=1、Item1="學號".....
我無法推知其content是如何取得(index我猜可能是順序遞加是嗎?)
如果我猜想d1(C) = ""這個程式碼的意義是
若C不在d1中，那麼就依序加入d1(index、count都加1)這樣對嗎?
那其語法為何?
另外
If C = "姓名" Then d1("班級") = "": d(A & "班級") = MyClass
中: 的意義是指在then的範圍之中，並且可以省略ENDIF是嗎?而不只是單純的分行符號
問題很蠢，但
尚請賜教

作者: Hsieh 時間: 2011-1-3 14:44

回復 19# asus103

dictionary物件觀念可用容器來做比喻
這個容器他是隨著資料多寡而跟著產生儲位的
這個儲位可以由使用者自行編號來表示
這個編號就是引數中的(index)key，關鍵字
至於這個儲位要放置的東西就是(content)item，內容
參考VBA說明
Dictionary 物件

描述

物件，用於儲存資料關鍵字和項目對。

語法

Scripting.Dictionary

請注意

Dictionary 可以是任何型式的資料的項目被儲存在陣列中。每個項目都與一個唯一的關鍵字相關。該關鍵字用來取出單個項目，通常是整數或字串，可以是除陣列外的任何型態。
由以上說明可知，
Dictionary 就是一個容器物件。
再看他有哪些方法?
add 加入項目
exists 檢查項目是否存在
items 傳回所有項目陣列
keys 傳回所有項目之關鍵字陣列
remove 移除項目
removeall 移除所有項目

VBA說明中對ADD方法有提到
Add 方法 (目錄)

描述

加入一對相對應的關鍵字和項目到 Dictionary 物件。

語法

object.Add key, item

Add方法的語法有如下幾個單元：

單元描述
Object 必要引數。一個 Dictionary 物件的名字。
Key 必要引數。與所加入的項目相關的關鍵字。
Item 必要引數。與所加入的關鍵字相關的項目。

請注意

如果該關鍵字已經存在，則產生一個錯誤。
所以，當使用ADD方法時若未先對關鍵字是否存在做檢查，若遇到已重複時就會產生錯誤。
所以我使用d(key)=item這樣的語法可避免這樣的麻煩。
所以當資料中，同樣關鍵字所參照到的內容若不相同時，此關鍵字儲位的內容將會被最後指定的值取代。
所以，dictionary物件的count屬性最簡單的說法就是，dictionary物件的關鍵字數量。

請注意該連結文章中語法的說明
dictionary_object.Add index, content
index就是索引值key
content就是內容item
d1(C) = ""這就是指定關鍵字C的那個儲位留空保存
所以你的解釋沒錯，若c不存在d1.COUNT就會加1

作者: asus103 時間: 2011-1-3 16:31

本帖最後由 asus103 於 2011-1-3 16:35 編輯

回復 20# Hsieh
Hsieh大大：
感謝您
之前我誤以為d1(C) = ""中C是content
我想它應該是index吧？
如果是這樣，我應該看得懂了

假如我說的沒錯，您就不必浪費您寶貴的時間回覆
若我的想法有錯，在麻煩您告知

但願有一天我也能寫出這樣有創意的程式
無限的感激

作者: Andy2483 時間: 2024-3-6 15:42

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習的方案如下,請各位前輩指教
執行結果:
[attach]37564[/attach]

Option Explicit
Sub TEST()
Dim Brr, Crr, Z, i&, j%, C%, N&, X%, T$, 班級$
工作表2.UsedRange.ClearContents
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range(工作表1.[N1], 工作表1.[B65536].End(3)(1, 0))
ReDim Crr(UBound(Brr), 1 To 20)
For i = 1 To UBound(Brr)
Z(Application.Text(i, "[DBNum1]")) = i
If Brr(i, 2) = "學　號" Then
   班級 = Z(Mid(Brr(i - 2, 2), 2, 1)) & Mid(Brr(i - 2, 2), 4, 2)
   For j = 5 To UBound(Brr, 2)
      T = Brr(i, j): If T = "" Then C = j - 1: Exit For
      If Not Z.Exists(T) Then X = X + 1: Z(T) = X + 4: Crr(0, X + 4) = T
      Z(j) = Z(T)
   Next
End If
If Brr(i, 2) Like "######" Then
   N = N + 1: For j = 5 To 20: Crr(N, j) = -1: Next
   Crr(N, 1) = Brr(i, 2): Crr(N, 2) = Brr(i, 3): Crr(N, 3) = 班級: Crr(N, 4) = Brr(i, 4)
   For j = 5 To C: Crr(N, Z(j)) = Brr(i, j): Next
End If
Next
With 工作表2.[A1].Resize(N + 1, X + 4): .NumberFormat = "@": .Value = Crr: End With
工作表2.[A1].Resize(, 4) = [{"學　號","姓名","班級","座號"}]
End Sub

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)