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

標題: [發問] 請問VBA可以做到兩檔案比對後再產生另一檔案的比對結果嗎? [打印本頁]

作者: happycoccolin 時間: 2013-7-25 11:09 標題: 請問VBA可以做到兩檔案比對後再產生另一檔案的比對結果嗎?

請問一下大師們~

目前手邊有一近五萬筆的資料庫--A資料我們需要將手邊的B資料與之做比對

請問VBA有沒有辦法做出一個檔案開啟後直接載入EXCEL的A檔案與B檔案比對後產生C檔案呢?
C檔案以B檔案格式為主向後多加欄位"K"
K欄位內容是A檔案的A欄位

比對內容是

A檔案的E欄位與 B檔案的J欄位比較(可忽略"-")

A檔案的格式如下
A                B          C                      D                      E
100-1    XXX    XXX                XXX                DOG
100-2    XXX    XXX                XXX                CAT
100-3    XXX    XXX                XXX                CAT-1
100-4    XXX    XXX                XXX                CAT-2

B檔案的格式如下
A                B          C                      D                      E                   F                      G          H             I          J
11          XX       XX                   XX                      XX                XX                      XX       XX          CC    DOG
12          XX       XX                   XX                      XX                XX                      XX       XX          CC    CAT
13          XX       XX                   XX                      XX                XX                      XX       XX          CC    CAT1
14          XX       XX                   XX                      XX                XX                      XX       XX          CC    CAT-1
15          XX       XX                   XX                      XX                XX                      XX       XX          CC    CAT3

比對結果希望產生C檔案
A                B          C                      D                      E                   F                      G          H             I          J             K
11          XX       XX                   XX                      XX                XX                      XX       XX          CC    DOG    100-1
12          XX       XX                   XX                      XX                XX                      XX       XX          CC    CAT       100-2
13          XX       XX                   XX                      XX                XX                      XX       XX          CC    CAT1       100-3
14          XX       XX                   XX                      XX                XX                      XX       XX          CC    CAT-1    100-3
15          XX       XX                   XX                      XX                XX                      XX       XX          CC    CAT3       No Data

作者: happycoccolin 時間: 2013-7-25 11:15

忘了附檔.....稍後附上檔案~

作者: happycoccolin 時間: 2013-7-25 11:21

回復 2# happycoccolin

:$ 若有空請大家看看是否可以達成~~~謝謝!!!!!

作者: vocolboy 時間: 2013-7-25 14:47

本帖最後由 vocolboy 於 2013-7-25 14:48 編輯

回復 1# happycoccolin

我也是剛學的不能下載付件直接從你上述的寫

Sub 比對()
Set d = CreateObject("Scripting.Dictionary")       '字典
With Workbooks("A.xls").Sheets(1)                      'with 報名名稱.工作表名稱
  For Each a In .Range(.[E2], .[E65536].End(xlUp))
d(a & "") = Array(a.Offset(, -4).Value)
  Next
End With
With Workbooks("B.xls").Sheets(1)
  For Each a In .Range(.[J2], .[J65536].End(xlUp))
a.Offset(, 1).Resize(, 1).Value = d(a & "")
  Next
End With
End Sub

這個結果並不會產生到C新的上
他會match在B裡面
我想這只是個複製貼上小問題@@

作者: happycoccolin 時間: 2013-7-25 16:14

回復 4# vocolboy

哈囉~~謝謝vocolboy ~

請問一下是否可以有一個檔案開啟以後讓我按鈕選擇載入兩個檔案比對呢?

例如

按鈕一  請選擇檔案
按鈕二  請選擇檔案
按鈕三  開始比對

作者: GBKEE 時間: 2013-7-25 16:56

回復 4# vocolboy

Option Explicit
Sub Ex()
Dim d As Object, i As Variant, S As Variant
Set d = CreateObject("scripting.dictionary")
i = 1
With Workbooks("A.xls").Sheets(1)
Do While .Cells(i, "e") <> ""
d(.Cells(i, "e").Value) = .Cells(i, "A").Value
i = i + 1
Loop
End With
i = 1
With Workbooks("B.xls").Sheets(1)
Do While .Cells(i, "J") <> ""
S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":J" & i))), ",")
If d.Exists(.Cells(i, "J").Value) Then
S = S & "," & d(.Cells(i, "J").Value)
d(.Cells(i, "J").Value) = Split(S, ",")
Else
d(.Cells(i, "J").Value) = Split(S & ",No Data", ",")
S = d(.Cells(i, "J").Value)
End If
i = i + 1
Loop
End With
For Each i In d.keys
If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i '可忽略"-"的步驟
Next
With Workbooks("C.xls").Sheets(1)
.Cells.Clear
S = Application.Transpose(Application.Transpose(d.ITEMS))
.[A1].Resize(UBound(S, 1), UBound(S, 2)) = S
End With
End Sub

複製代碼

作者: happycoccolin 時間: 2013-7-25 18:20

回復 6# GBKEE

謝謝版大~~~

抱歉小妹才疏學淺......

請問一下要怎麼使用才能做比對呢?

我將語法複製到模組中但是如何才能正確使用?

目前偵錯停在
With Workbooks("A.xls").Sheets(1)

對VBA很有興趣但是未開竅目前腳步很慢尚停留在函數階段也請各位大師們多多見諒我問的笨問題..

作者: GBKEE 時間: 2013-7-25 19:24

回復 7# happycoccolin
xls 是2003版活頁簿的副檔名
2007版以後的副檔名xlsx是沒有巨集的活頁簿 ,副檔名xlsm是有巨集的活頁簿.

作者: happycoccolin 時間: 2013-7-26 11:34

回復 8# GBKEE

謝謝板大~

可以再請問一下嗎~如何不指定檔名~要做到人人都可以利用此檔案來做比對

那可以怎麼處理呢?

我現在是以A.xlsx為主,sheet1我加一個按鈕直接RUN此比對

如何載入欲比對的檔案呢?

作者: GBKEE 時間: 2013-7-26 13:47

回復 9# happycoccolin

Option Explicit
Sub Ex()
Dim d As Object, i As Variant, S As Variant, Wb As Workbook
Set d = CreateObject("scripting.dictionary")
With Application.FileDialog(msoFileDialogFilePicker) 'FileDialog :表檔案對話方, msoFileDialogFilePicker(參數):選取檔案
.AllowMultiSelect = False '允許使用者從檔案對話方塊選取多個檔案=False
If .Show = False Then MsgBox "沒有選擇檔案 !!!": Exit Sub
Set Wb = Workbooks.Open(.SelectedItems(1)) '開啟指定檔案
End With
i = 1
With Workbooks("A.xlsx").Sheets(1) '
Do While .Cells(i, "e") <> ""
d(.Cells(i, "e").Value) = .Cells(i, "A").Value
i = i + 1
Loop
End With
i = 1
With Wb.Sheets(1)
Do While .Cells(i, "J") <> ""
S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":J" & i))), ",")
If d.Exists(.Cells(i, "J").Value) Then
S = S & "," & d(.Cells(i, "J").Value)
d(.Cells(i, "J").Value) = Split(S, ",")
Else
d(.Cells(i, "J").Value) = Split(S & ",No Data", ",")
S = d(.Cells(i, "J").Value)
End If
i = i + 1
Loop
.Parent.Close False '關閉指定檔案不存檔
End With
For Each i In d.keys
If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i '可忽略"-"的步驟
Next
With Workbooks("C.xlsx").Sheets(1)
.Cells.Clear
S = Application.Transpose(Application.Transpose(d.ITEMS))
.[A1].Resize(UBound(S, 1), UBound(S, 2)) = S
End With
End Sub

複製代碼

作者: happycoccolin 時間: 2013-7-26 14:19

回復 10# GBKEE

謝謝板大!!!!!!

但是偵錯目前停在
With Workbooks("C.xlsx").Sheets(1)

是不是若我不指定新檔案的檔名就不會有錯誤呢?

應該是說比對完成後跑出的檔案由使用者自定義名稱

抱歉問題很多

我附上檔案給您參考
ABC.xlsm為資料庫
B.xlsx為欲比對檔案
希望比對後產生一新檔案(由使用者自定義名稱另存新檔)
[attach]15585[/attach]

很高興板大願意解惑~^^

作者: GBKEE 時間: 2013-7-26 14:38

本帖最後由 GBKEE 於 2013-7-26 17:05 編輯

回復 11# happycoccolin

Option Explicit
Sub Ex()
Dim d As Object, i As Variant, S As Variant, Wb As Workbook, Wb_Name As String
Set d = CreateObject("scripting.dictionary")
With Application.FileDialog(msoFileDialogFilePicker) 'FileDialog :表檔案對話方, msoFileDialogFilePicker(參數):選取檔案
.AllowMultiSelect = False '允許使用者從檔案對話方塊選取多個檔案=False
If .Show = False Then MsgBox "沒有選擇檔案 !!!": Exit Sub
Set Wb = Workbooks.Open(.SelectedItems(1)) '開啟指定檔案
End With
i = 1
With Workbooks("A.xlsx").Sheets(1) '
Do While .Cells(i, "e") <> ""
d(.Cells(i, "e").Value) = .Cells(i, "A").Value
i = i + 1
Loop
End With
i = 1
With Wb.Sheets(1)
Do While .Cells(i, "J") <> ""
S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":J" & i))), ",")
If d.Exists(.Cells(i, "J").Value) Then
S = S & "," & d(.Cells(i, "J").Value)
d(.Cells(i, "J").Value) = Split(S, ",")
Else
d(.Cells(i, "J").Value) = Split(S & ",No Data", ",")
S = d(.Cells(i, "J").Value)
End If
i = i + 1
Loop
.Parent.Close False '關閉指定檔案不存檔
End With
For Each i In d.keys
If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i '可忽略"-"的步驟
Next
Do
Wb_Name = InputBox("輸入新檔名", "存檔名稱")
Loop Until Wb_Name <> "" '直到有輸入字串離開迴圈
Set Wb = Workbooks.Add(1)
With Wb.Sheets(1)
.Cells.Clear
S = Application.Transpose(Application.Transpose(d.ITEMS))
.[A1].Resize(UBound(S, 1), UBound(S, 2)) = S
End With
Wb.SaveAs "D:\TEST\" & Wb_Name & "XLSX" '存檔的完整名稱
End Sub

複製代碼

作者: happycoccolin 時間: 2013-7-26 15:21

回復 12# GBKEE

感謝板大的迅速回覆~~~

請問一下目前偵錯停在
Sub Ex()

我現在要怎麼處理呢?

謝謝板大的幫忙!!!!!!!

作者: GBKEE 時間: 2013-7-26 15:27

回復 13# happycoccolin
同一個模組中不能有相同的程序名稱 Sub Ex()
找找看還有第2個 Sub Ex() 嗎?

作者: happycoccolin 時間: 2013-7-26 16:58

回復 14# GBKEE

版大~~只有一個Ex~~~我有附檔~~>< 拜託幫忙撥空看一下好嗎~
感激不盡!!!

[attach]15589[/attach]

作者: GBKEE 時間: 2013-7-26 17:03

回復 15# happycoccolin
不好意思改一下最後 Save -> SaveAs

Wb.SaveAs "D:\TEST\" & Wb_Name & "XLSX" '存檔的完整名稱

複製代碼

作者: happycoccolin 時間: 2013-7-26 18:06

回復 16# GBKEE

謝謝版大的幫忙~~~~

再請教一下~目前偵錯停在
With Workbooks("A.xlsx").Sheets(1) '

因為我已經將資料庫放在ABC.xlsm裡面了

那下面這段語法是否就不用針對A.xlsx做處理呢?

i = 1
With Workbooks("A.xlsx").Sheets(1) '
      Do While .Cells(i, "e") <> ""
         d(.Cells(i, "e").Value) = .Cells(i, "A").Value
         i = i + 1
      Loop

作者: GBKEE 時間: 2013-7-26 19:58

回復 17# happycoccolin
因為我已經將資料庫放在ABC.xlsm裡面了
With Workbooks("A.xlsx").Sheets(1) -改一下檔名 With Workbooks("ABC.xlsm").Sheets(1)

作者: happycoccolin 時間: 2013-7-30 10:54

回復 18# GBKEE

報告版大~

目前偵錯停在
Wb.SaveAs "D:\TEST\" & Wb_Name & "XLSX" '存檔的完整名稱

可是比對結果通通都是NO DATA耶~

請見附檔
[attach]15636[/attach]

作者: GBKEE 時間: 2013-7-30 14:43

回復 19# happycoccolin
可是比對結果通通都是NO DATA
問題在這裡

With Workbooks("ABC.xlsm").Sheets(1)
'這Sheets(1) 是ABC.xlsm的第一個工作表 (MAIN)
'是否要改成 Sheets(2) -> 第二個工作表 (A)
Do While .Cells(i, "e") <> ""
d(.Cells(i, "e").Value) = .Cells(i, "A").Value
i = i + 1
Loop
End With

複製代碼

D:\TEST \ 這資料夾是我隨意寫的,你需改為你PC中存在的資料夾

作者: happycoccolin 時間: 2013-7-30 16:16

回復 20# GBKEE

謝謝版大~~~成功了~~

但是是否可不指定儲存位置[ D:\TEXT ] 可讓使用者自行設定儲存位置或選擇要不要存檔?

再問一下比對檔案B.XLSX 欄位由"J"向後順延為"K"

只修改以下後偵錯沒有問題
With Wb.Sheets(1)
      Do While .Cells(i, "K") <> ""
         S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":K" & i))), ",")
         If d.Exists(.Cells(i, "K").Value) Then
            S = S & "," & d(.Cells(i, "K").Value)
            d(.Cells(i, "K").Value) = Split(S, ",")
         Else
            d(.Cells(i, "K").Value) = Split(S & ",No Data", ",")
            S = d(.Cells(i, "K").Value)

         End If
         i = i + 1
      Loop
      .Parent.Close False             '關閉指定檔案不存檔
End With

但因為B.xlsx比對欄位"K"後還有一欄"L"
新產生的檔案資料會向後順延一欄填到"M"嗎?

偵錯現在停在
S = Application.Transpose(Application.Transpose(d.ITEMS))

[attach]15641[/attach]

作者: happycoccolin 時間: 2013-7-31 12:11

回復 20# GBKEE

報告版大~前一篇描述不清楚~我重新描述一下

目前B.xlsx的比對欄位要更動到"K"

再請教是否可以將比對好的值填到最後一個欄位呢?不要做覆蓋填上的動作呢?

請見附檔~~~謝謝~
[attach]15653[/attach]

ABC.xlsx
A B C D E
100-1 XXX XXX XXX DOG
100-2 XXX XXX XXX CAT
100-3 XXX XXX XXX CAT-1
100-4 XXX XXX XXX CAT-2

↑比對完畢後Show出此欄位值 ↑比對欄位

B.xlsx

A B C D E F G H I J K L 希望顯示在這欄位(M)
11 XX XX XX 1 A1 XX XX XX CC DOG XX
12 XX XX XX 2 A2 XX XX XX CC CAT XX
13 XX XX XX 2 A3 XX XX XX CC CAT1 XX
14 XX XX XX 1 A4 XX XX XX CC CAT-1 XX
15 XX XX XX 1 A5 XX XX XX CC CAT3 XX

↑比對欄位 ↑若有多一欄位產生的比對資料是否可向後順延到M呢?
應該說是否可自動填在最後一欄呢?

而且這次CAT1沒有被比對出來~~
附檔
[attach]15652[/attach]

11 XX XX XX XX XX XX XX CC DOG 100-1
12 XX XX XX XX XX XX XX CC CAT 100-2
14 XX XX XX XX XX XX XX CC CAT-1 100-3
13 XX XX XX XX XX XX XX CC CAT1 No Data
15 XX XX XX XX XX XX XX CC CAT3 No Data

請版大撥空看看好嗎~謝謝~!!!!

作者: stillfish00 時間: 2013-7-31 20:38

回復 22# happycoccolin
CAT1 資料庫原本就沒有不是嗎?

作者: happycoccolin 時間: 2013-8-1 09:06

回復 23# stillfish00

哈囉~因為有這一段

比較(可忽略"-")

If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i '可忽略"-"的步驟

所以應該要判斷成"100-3".....

作者: stillfish00 時間: 2013-8-1 10:01

回復 24# happycoccolin
1.  所以你希望的是有含 "-"和沒含"-"的兩個是對應到相同結果?

2.  0730的檔案不含標頭，0731的含標頭哪個才是正確的資料?

3.  選擇比對的資料表欄位不固定，但是要比對的都是最後一欄?

作者: happycoccolin 時間: 2013-8-1 11:42

回復 25# stillfish00

哈囉~~~

1.  所以你希望的是有含 "-"和沒含"-"的兩個是對應到相同結果?
   YES

2.  0730的檔案不含標頭，0731的含標頭哪個才是正確的資料?
   0730是原本請版主幫忙的 ,而0731含標頭是後來發現比對的欄位有向後移一欄因此FINAL是希望參考0731的樣子

3.  選擇比對的資料表欄位不固定，但是要比對的都是最後一欄?
   比對的欄位是固定的資料庫ABC.xlsx中的"E"欄位與待比對檔案B.xlsx的"K'欄位比較
   希望將比對後的結果(ABC.xlsx的"A"欄位資料)填入一個跟B.xlsx相同的新檔案最後一欄位(目前是"M"欄)
   現在的寫法若填入資料是會覆蓋原本的欄位希望能夠產生一新欄位而不是用覆蓋寫入

作者: stillfish00 時間: 2013-8-1 12:17

本帖最後由 stillfish00 於 2013-8-1 12:26 編輯

回復 26# happycoccolin
先將 B_0731.xlsx "希望顯示在這欄位" 字樣刪掉儲存關閉後，再執行。

Sub TEST()
Const DATABASE_NAME = "A" '資料庫工作表名稱
Const DATABASE_COL = 5 'E欄
Const COMPARE_COL = 11 'K欄
Dim d, ar, filein, fileout, s, i As Long
Set d = CreateObject("scripting.dictionary")
ar = Sheets(DATABASE_NAME).[A1].CurrentRegion.Value
For i = 2 To UBound(ar)
d(Replace(ar(i, DATABASE_COL), "-", "")) = ar(i, 1)
Next
filein = Application.GetOpenFilename(Title:="選擇要比對的檔案")
If Not TypeName(filein) = "String" Then Exit Sub '取消則結束
Application.ScreenUpdating = False
With Workbooks.Open(filein)
ar = .Sheets(1).[A1].CurrentRegion.Value
.Close False
End With
Application.ScreenUpdating = True
ReDim Preserve ar(LBound(ar) To UBound(ar), LBound(ar, 2) To UBound(ar, 2) + 1)
For i = LBound(ar) + 1 To UBound(ar)
s = Replace(ar(i, COMPARE_COL), "-", "")
If d.exists(s) Then
ar(i, UBound(ar, 2)) = d(s)
Else
ar(i, UBound(ar, 2)) = "No Data"
End If
Next
fileout = Application.GetSaveAsFilename(Title:="另存為新檔")
If Not TypeName(fileout) = "String" Then Exit Sub '取消則結束
With Workbooks.Add.Sheets(1)
.[A1].Resize(UBound(ar), UBound(ar, 2)).Value = ar
.Parent.SaveAs fileout
End With
End Sub

複製代碼

作者: happycoccolin 時間: 2013-8-1 12:52

回復 27# stillfish00

謝謝stillfish00~~~~

我來run一下~感恩您的幫忙~~

作者: happycoccolin 時間: 2013-8-1 16:21

回復 27# stillfish00

哈囉~~stillfish00 ~~^^

剛剛試過OK~

但是有幾個問題

1.若資料庫中有空白行,就會停止比對導致B.xlsx最後一個與資料庫對應的欄位下一行皆變成NO DATA
(目前資料庫預計有50000行左右的資料) 剛剛有先放進去比對發現結果通通都是NO DATA

[attach]15666[/attach]

2.是否可以讓user選擇存檔與否不要直接先跳出存檔的視窗呢?
p.s.目前儲存的檔案是沒有檔案類型的

3.是否可讓比對好的檔案資料有格線及自動調整欄寬?可設定字型與大小嗎?

抱歉問題很多~拜託拜託~~~~~~~

作者: stillfish00 時間: 2013-8-2 10:12

回復 29# happycoccolin

Sub TEST()
Const DATABASE_NAME = "A" '資料庫工作表名稱
Const DATABASE_COL = 5 'E欄
Const COMPARE_COL = 11 'K欄
Dim d, ar, filein, fileout, s, i As Long
Set d = CreateObject("scripting.dictionary")
With Sheets(DATABASE_NAME)
ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
For i = 2 To UBound(ar)
d(Replace(ar(i, DATABASE_COL), "-", "")) = ar(i, 1)
Next
filein = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇要比對的檔案")
If Not TypeName(filein) = "String" Then Exit Sub '取消則結束
Application.ScreenUpdating = False
With Workbooks.Open(filein).Sheets(1)
ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
.Parent.Close False
End With
Application.ScreenUpdating = True
ReDim Preserve ar(LBound(ar) To UBound(ar), LBound(ar, 2) To UBound(ar, 2) + 1)
For i = LBound(ar) + 1 To UBound(ar)
s = Replace(ar(i, COMPARE_COL), "-", "")
If d.exists(s) Then
ar(i, UBound(ar, 2)) = d(s)
Else
ar(i, UBound(ar, 2)) = "No Data"
End If
Next
With Workbooks.Add
Application.ScreenUpdating = False
With .Sheets(1).[A1].Resize(UBound(ar), UBound(ar, 2))
.Value = ar
.Font.Name = "Verdana" '字體名稱
.Font.Size = 14 '字體大小
.Borders.LineStyle = xlContinuous '框線
.EntireColumn.AutoFit '調整欄寬
.Rows(1).Interior.Color = 12567966 '標頭顏色
.Rows(1).Font.Bold = True '標頭粗體字
End With
Application.ScreenUpdating = True
If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
fileout = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
If Not TypeName(fileout) = "String" Then Exit Sub '取消則結束
.SaveAs fileout, FileFormat:=xlWorkbookDefault
End If
End With
End Sub

複製代碼

作者: happycoccolin 時間: 2013-8-2 11:05

回復 30# stillfish00

哈囉~stillfish00

太棒了~~^^ 太感恩~

只是還有兩個小問題~
1.目前若是空白的欄位他也會做判斷

若B.xlsx的"K"欄是空白的

他會去讀取資料庫的"E"欄空白位置第一個的對應值寫在新檔案裡面但是其實那欄應該要是空白

2.若是資料庫的"E"欄位同時在"A"欄位有兩筆以上對應那怎麼比對出來?
目前跟VLOOKUP一樣只能一對一 VBA可做出一對多嗎?

而本次比對結果出來不是對應到第一筆而是空白行後的第一筆(請見附檔Book21.xlsx)

[attach]15671[/attach]

謝謝謝謝!!!!持續研讀中

作者: stillfish00 時間: 2013-8-2 11:45

回復 31# happycoccolin
上傳的例子，盡量保留原本資料的特性(如:是否含標頭、是否有空白、是否會有重複項等等)，才會比較符合實際想要的結果。

Sub TEST()
Const DATABASE_NAME = "A" '資料庫工作表名稱
Const DATABASE_COL = 5 'E欄
Const COMPARE_COL = 11 'K欄
Dim d, ar, filein, fileout, s As String, i As Long
Set d = CreateObject("scripting.dictionary")
With Sheets(DATABASE_NAME)
ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
For i = 2 To UBound(ar)
s = Replace(ar(i, DATABASE_COL), "-", "")
If s <> "" Then
If d.exists(s) Then
d(s) = d(s) & "," & ar(i, 1)
Else
d(s) = ar(i, 1)
End If
End If
Next
filein = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇要比對的檔案")
If Not TypeName(filein) = "String" Then Exit Sub '取消則結束
Application.ScreenUpdating = False
With Workbooks.Open(filein).Sheets(1)
ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
.Parent.Close False
End With
Application.ScreenUpdating = True
ReDim Preserve ar(LBound(ar) To UBound(ar), LBound(ar, 2) To UBound(ar, 2) + 1)
For i = LBound(ar) + 1 To UBound(ar)
If ar(i, COMPARE_COL) <> "" Then
s = Replace(ar(i, COMPARE_COL), "-", "")
If d.exists(s) Then
ar(i, UBound(ar, 2)) = d(s)
Else
ar(i, UBound(ar, 2)) = "No Data"
End If
End If
Next
With Workbooks.Add
Application.ScreenUpdating = False
With .Sheets(1).[A1].Resize(UBound(ar), UBound(ar, 2))
.Value = ar
.Font.Name = "Verdana" '字體名稱
.Font.Size = 14 '字體大小
.Borders.LineStyle = xlContinuous '框線
.EntireColumn.AutoFit '調整欄寬
.Rows(1).Interior.Color = 12567966 '標頭顏色
.Rows(1).Font.Bold = True '標頭粗體字
End With
Application.ScreenUpdating = True
If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
fileout = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
If Not TypeName(fileout) = "String" Then Exit Sub '取消則結束
.SaveAs fileout, FileFormat:=xlWorkbookDefault
End If
End With
End Sub

複製代碼

作者: happycoccolin 時間: 2013-8-2 12:36

回復 32# stillfish00

哈囉~~stillfish00

也太快速了~~抱歉忙中有錯~練習的檔案太多搞混了~

感謝幫忙解答~~~

再問一個問題

一對多重複的資料中是否可以只取不重複的並在同一欄位內做換行動作呢?

還有若是產生的檔案其中一欄位太寬大可以用VBA處理讓他最大只到欄寬50(並自動換列)這一類的設定嗎?

抱歉小妹這初學者問的問題都很莫名其妙也謝謝你們能夠耐心解答

再次謝謝謝謝～~~~~

作者: happycoccolin 時間: 2013-8-2 12:53

回復 32# stillfish00

哈囉～stillfish00

我知道了　下次會注意　感謝大大的耐心解答

作者: stillfish00 時間: 2013-8-2 13:42

回復 33# happycoccolin

若是產生的檔案其中一欄位太寬大可以用VBA處理讓他最大只到欄寬50(並自動換列)

你指的對象是指自動調整欄寬後的所有欄都檢查，還是只要單一欄(哪一欄?)

作者: happycoccolin 時間: 2013-8-2 13:58

回復 35# stillfish00

HELLO~stillfish00

目前是"K"欄與"M"欄,因為資料量比較多所以都會拉到欄寬250左右~

作者: happycoccolin 時間: 2013-8-2 14:05

回復 35# stillfish00

HELLO~~~SORRY~~~剛剛寫錯了~~~

目前是"F"欄與"M"欄,因為資料量比較多所以都會拉到欄寬250左右~

作者: stillfish00 時間: 2013-8-2 14:11

本帖最後由 stillfish00 於 2013-8-2 14:13 編輯

回復 33# happycoccolin

一對多重複的資料中是否可以只取不重複的並在同一欄位內做換行動作呢?
還有若是產生的檔案其中一欄位太寬大可以用VBA處理讓他最大只到欄寬50(並自動換列)這一類的設定嗎?

Sub TEST()
Const DATABASE_NAME = "A" '資料庫工作表名稱
Const DATABASE_COL = 5 'E欄
Const COMPARE_COL = 11 'K欄
Dim d, ar, filein, fileout, s As String, i As Long
Set d = CreateObject("scripting.dictionary")
With Sheets(DATABASE_NAME)
ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
For i = 2 To UBound(ar)
s = Replace(ar(i, DATABASE_COL), "-", "")
If s <> "" Then
If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
d(s)(ar(i, 1)) = "" '第二層字典，用來篩選掉重複的A欄值
End If
Next
filein = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇要比對的檔案")
If Not TypeName(filein) = "String" Then Exit Sub '取消則結束
Application.ScreenUpdating = False
With Workbooks.Open(filein).Sheets(1)
ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
.Parent.Close False
End With
Application.ScreenUpdating = True
ReDim Preserve ar(LBound(ar) To UBound(ar), LBound(ar, 2) To UBound(ar, 2) + 1)
For i = LBound(ar) + 1 To UBound(ar)
If ar(i, COMPARE_COL) <> "" Then
s = Replace(ar(i, COMPARE_COL), "-", "")
If d.exists(s) Then
ar(i, UBound(ar, 2)) = Join(d(s).keys, vbLf)
Else
ar(i, UBound(ar, 2)) = "No Data"
End If
End If
Next
With Workbooks.Add
Application.ScreenUpdating = False
With .Sheets(1).[A1].Resize(UBound(ar), UBound(ar, 2))
.Value = ar
.Font.Name = "Verdana" '字體名稱
.Font.Size = 14 '字體大小
.Borders.LineStyle = xlContinuous '框線
.EntireColumn.AutoFit '調整欄寬
.Rows(1).Interior.Color = 12567966 '標頭顏色
.Rows(1).Font.Bold = True '標頭粗體字
'欄寬限制及自動換行
With .Columns("F")
If .Width > 250 Then
.Width = 250
.WrapText = True
End If
End With
With .Columns("M")
If .Width > 250 Then
.Width = 250
.WrapText = True
End If
End With
End With
Application.ScreenUpdating = True
If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
fileout = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
If Not TypeName(fileout) = "String" Then Exit Sub '取消則結束
.SaveAs fileout, FileFormat:=xlWorkbookDefault
End If
End With
End Sub

複製代碼

作者: happycoccolin 時間: 2013-8-2 14:29

本帖最後由 happycoccolin 於 2013-8-2 14:32 編輯

回復 38# stillfish00

哈囉~~~~~~~請問一下~~目前狀況如下

With .Columns("F")
      If .Width > 250 Then
      .Width = 250 (偵錯停在這一行)
      .WrapText = True
      End If
   End With
   With .Columns("M")
      If .Width > 250 Then
      .Width = 250
      .WrapText = True
      End If

"F"欄可不用逐筆資料自動換列只要調整欄寬就好

作者: stillfish00 時間: 2013-8-2 14:50

回復 39# happycoccolin
抱歉，請將 .Width 都改為 .ColumnWidth，250改為適合的欄寬(非像素)

作者: happycoccolin 時間: 2013-8-2 15:07

回復 38# stillfish00

哈囉 stillfish00 大大

謝謝您的耐心溝通與協助!
成功了!!!!!放煙火~

也謝謝在這版幫助過我的版大與版友們

真的很感激大家的耐心解惑

也希望有朝一日我也能成為幫助人的角色

作者: happycoccolin 時間: 2013-8-15 11:46

回復 40# stillfish00

S大~不好意思想請教一下~如何將資料填入表頭呢?

我現在需要用到將某份資料轉檔,就差表頭名稱及欄位不同,也不用比對

我使用最笨的方法錄製巨集但是表頭資料不知如何輸入~可以幫忙看看嗎~謝謝

Sub Macro1()
'
' Macro1 Macro
'

'
Rows("1:1").Select
ActiveSheet.Paste
Range("B6").Select
Workbooks.Open Filename:="C:\Users\Documents\VB\2\A_0814.xlsx"
Range("A6:A50000").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book2").Activate
ActiveWindow.SmallScroll Down:=-3
Range("B2").Select
ActiveSheet.Paste
Windows("A_0814.xlsx").Activate
Range("B6:B50000").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book2").Activate
Range("D2").Select
ActiveSheet.Paste
End Sub

作者: stillfish00 時間: 2013-8-15 13:15

回復 42# happycoccolin
不明白你的意思，
要連表頭貼過去? 複製時一起選就好啦

能否上傳檔案再說明清點?

作者: happycoccolin 時間: 2013-8-15 13:40

回復 43# stillfish00

S大~~~我有另開一個提問~在以下路徑~

http://forum.twbts.com/thread-10164-1-1.html

因為目前需要將一個檔案中特定幾欄的資料取出(不用比對) 並產生一新檔案填入特定欄位

兩個檔案的表頭及欄位是不同的

而且目前A.xlsx是不固定的需要由User自行選擇載入

有試著用之前的檔案修改但是語法不純熟尚在學習中所以想請教S大~~~

謝謝S大的回覆~~

作者: stillfish00 時間: 2013-8-15 15:32

回復 44# happycoccolin

Sub TEST()
Dim ar, r As Long, i As Long
Dim cIndexOld, cIndexNew, arNewHeader
Dim f
cIndexOld = Array(2, 3, 4, 5, 7, 8) 'A檔案中要搬動的欄
cIndexNew = Array(2, 4, 21, 24, 43, 44) '搬到B檔位置(欄號)
arNewHeader = Array("W", "R", "X", "B", "JJ", "KK") 'B檔標題名稱
f = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇來源檔案")
If Not TypeName(f) = "String" Then Exit Sub '取消則結束
Application.ScreenUpdating = False
With Workbooks.Open(f)
With .Sheets(1)
ar = .Range("A5:H" & .[A5].CurrentRegion.Rows.Count).Value
End With
.Close False
End With
Application.ScreenUpdating = True
r = UBound(ar)
With Workbooks.Add
With .Sheets(1)
For i = LBound(cIndexOld) To UBound(cIndexOld)
.Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
.Cells(1, cIndexNew(i)).Value = arNewHeader(i)
Next
End With
If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
f = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
If Not TypeName(f) = "String" Then Exit Sub '取消則結束
.SaveAs f, FileFormat:=xlWorkbookDefault
End If
End With
End Sub

複製代碼

作者: happycoccolin 時間: 2013-8-15 15:44

本帖最後由 happycoccolin 於 2013-8-15 15:54 編輯

回復 43# stillfish00

S大~若有的檔案是B5欄開始有的是B6欄開始可以怎麼判斷?

還有若是新表格所有欄位都要有TITLE 可以都填上嗎~

謝謝Stillfish00大大!

作者: happycoccolin 時間: 2013-8-15 16:11

回復 45# stillfish00

S大~~~可以再請教一下這一段是在描述甚麼動作嗎~

Application.ScreenUpdating = False
  With Workbooks.Open(f)  這應該是指新開的資料檔嗎?
With .Sheets(1)
   ar = .Range("A5:H" & .[A5].CurrentRegion.Rows.Count).Value 這句不懂甚麼意思
End With
.Close False
  End With
  Application.ScreenUpdating = True

  r = UBound(ar)
  With Workbooks.Add
With .Sheets(1)
   For i = LBound(cIndexOld) To UBound(cIndexOld)
      .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
      .Cells(1, cIndexNew(i)).Value = arNewHeader(i)
   Next
End With

作者: stillfish00 時間: 2013-8-15 17:46

本帖最後由 stillfish00 於 2013-8-15 17:49 編輯

回復 46# happycoccolin

若有的檔案是B5欄開始有的是B6欄開始可以怎麼判斷?

不知道，
而且你的A_0814.xlsx檔案挺怪的！
[A4]儲存格明明沒文字(也沒有不可見字元)，卻又不是空白儲存格(尋找>特殊目標>空白，不會找到)
用Ctrl+上下也都會跳過。
第一次遇到這種情形~

若是新表格所有欄位都要有TITLE 可以都填上嗎~

改一下

arNewHeader = Array("Q", "W", "E", "R", "T", "Y", "U", "I") '自己填上全部新標題名稱

複製代碼

還有這邊

With .Sheets(1)
For i = LBound(cIndexOld) To UBound(cIndexOld)
.Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
Next
.[A1].Resize(, UBound(arNewHeader) + 1).Value = arNewHeader
End With

複製代碼

作者: happycoccolin 時間: 2013-8-16 10:15

回復 48# stillfish00

哈囉S大~我試過了~~~感激不盡~

想請問一下若是我要跑資料從B5開始的是要修改哪邊呢?

還是可以用判斷TITLE這種方式處理嗎?

EX:若TITLE(B4)是"Item"就從下一格(B5)開始取資料一類的

不好意思..又以一般人的想法來提問~@@

謝謝S大的耐心與幫忙

作者: stillfish00 時間: 2013-8-16 11:26

回復 49# happycoccolin

Sub TEST()
Dim ar, r As Long, i As Long
Dim cIndexOld, cIndexNew, arNewHeader
Dim f, findTitle
cIndexOld = Array(2, 3, 4, 5, 7, 8) 'A檔案中要搬動的欄
cIndexNew = Array(2, 4, 21, 24, 43, 44) '搬到B檔位置
arNewHeader = Array("Q", "W", "E", "R", "T", "Y", "U", "I") '自己填全部B檔標題名稱
f = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇來源檔案")
If Not TypeName(f) = "String" Then Exit Sub '取消則結束
Application.ScreenUpdating = False
With Workbooks.Open(f)
With .Sheets(1)
Set findTitle = .Cells.Find("Item", , xlValues, xlWhole, xlByRows, xlNext) '找標題 Item
If findTitle Is Nothing Then MsgBox "找不到標題": Exit Sub
With findTitle.CurrentRegion
ar = .Parent.Range(findTitle, .Cells(.Rows.Count, .Columns.Count)).Value
End With
End With
.Close False
End With
Application.ScreenUpdating = True
r = UBound(ar)
With Workbooks.Add
With .Sheets(1)
For i = LBound(cIndexOld) To UBound(cIndexOld)
.Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
Next
.[A1].Resize(, UBound(arNewHeader) + 1).Value = arNewHeader
End With
If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
f = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
If Not TypeName(f) = "String" Then Exit Sub '取消則結束
.SaveAs f, FileFormat:=xlWorkbookDefault
End If
End With
End Sub

複製代碼

作者: happycoccolin 時間: 2013-8-16 12:12

回復 50# stillfish00

謝S大的超快速解答~

我來多跑幾個檔案試試看~

目前有一段會有問題我再多RUN幾個檔案看格式哪邊有不同~

.Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))

謝Stillfish00大~^________^

作者: happycoccolin 時間: 2013-8-16 14:04

回復 50# stillfish00

S大~~我想加入這兩行~但是一直有錯可以幫忙看一下嗎~~~謝謝~~~~
With Workbooks.Add
   With .Sheets(1)
   .Font.Name = "Tahoma"  '字體名稱
   .Font.Size = 10 '字體大小
   End With
End With

作者: stillfish00 時間: 2013-8-16 14:39

回復 52# happycoccolin
要給儲存格範圍，如
With Workbooks.Add
   With .Sheets(1)
      .[A1:H1].Font.Name = "Tahoma"  '字體名稱
      .[A1:H1].Font.Size = 10 '字體大小
   End With
End With

作者: happycoccolin 時間: 2013-8-16 15:13

回復 53# stillfish00

瞭解了~~~~S大~^_____^

那若是整個sheet都要設定可以怎麼改~

我現在是這樣寫

.[A1:AV10000].Font.Name = "Tahoma" '字體名稱
.[A1:AV10000].Font.Size = 10 '字體大小

作者: stillfish00 時間: 2013-8-16 15:23

回復 54# happycoccolin
.Cells 就代表工作表中的所有儲存格了

With Workbooks.Add
With .Sheets(1).Cells
.Font.Name = "Tahoma" '字體名稱
.Font.Size = 10 '字體大小
End With
End With

複製代碼

作者: happycoccolin 時間: 2013-8-16 15:36

回復 55# stillfish00

謝謝S大~~~~~~~~~^^

只是若要跟程式結合我還是有問題~~~@@

加錯地方整個程式RUN出來是空白的.........

  r = UBound(ar)
  With Workbooks.Add
   With .Sheets(1)
   For i = LBound(cIndexOld) To UBound(cIndexOld)
      .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
   Next
   .[A1].Resize(, UBound(arNewHeader) + 1).Value = arNewHeader
   .[A1:AV10000].Font.Name = "Arial"  '字體名稱
   .[A1:AV10000].Font.Size = 10 '字體大小

End With

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