請問VBA可以做到兩檔案比對後再產生另一檔案的比對結果嗎? - Excel程式區

happycoccolin

　暱稱: NANAKO

中學生 Rank: 2

帖子: 72
主題: 7
精華: 0
積分: 88
點名: 0
作業系統: Windows 7
軟體版本: Office 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-28
最後登錄: 2018-11-14

31^# 跳轉到 »

發表於 2013-8-2 11:05 | 只看該作者

回復 30# stillfish00

哈囉~stillfish00

太棒了~~^^ 太感恩~

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

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

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

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

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

ABC_0802.zip (30.5 KB)

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

TOP

stillfish00

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

32^#

發表於 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

複製代碼

TOP

happycoccolin

　暱稱: NANAKO

中學生 Rank: 2

帖子: 72
主題: 7
精華: 0
積分: 88
點名: 0
作業系統: Windows 7
軟體版本: Office 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-28
最後登錄: 2018-11-14

33^#

發表於 2013-8-2 12:36 | 只看該作者

回復 32# stillfish00

哈囉~~stillfish00

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

感謝幫忙解答~~~

再問一個問題

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

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

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

再次謝謝謝謝～~~~~

TOP

happycoccolin

　暱稱: NANAKO

中學生 Rank: 2

帖子: 72
主題: 7
精華: 0
積分: 88
點名: 0
作業系統: Windows 7
軟體版本: Office 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-28
最後登錄: 2018-11-14

34^#

發表於 2013-8-2 12:53 | 只看該作者

回復 32# stillfish00

哈囉～stillfish00

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

TOP

stillfish00

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

35^#

發表於 2013-8-2 13:42 | 只看該作者

回復 33# happycoccolin

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

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

TOP

happycoccolin

　暱稱: NANAKO

中學生 Rank: 2

帖子: 72
主題: 7
精華: 0
積分: 88
點名: 0
作業系統: Windows 7
軟體版本: Office 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-28
最後登錄: 2018-11-14

36^#

發表於 2013-8-2 13:58 | 只看該作者

回復 35# stillfish00

HELLO~stillfish00

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

TOP

happycoccolin

　暱稱: NANAKO

中學生 Rank: 2

帖子: 72
主題: 7
精華: 0
積分: 88
點名: 0
作業系統: Windows 7
軟體版本: Office 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-28
最後登錄: 2018-11-14

37^#

發表於 2013-8-2 14:05 | 只看該作者

回復 35# stillfish00

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

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

TOP

stillfish00

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

38^#

發表於 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

複製代碼

TOP

happycoccolin

　暱稱: NANAKO

中學生 Rank: 2

帖子: 72
主題: 7
精華: 0
積分: 88
點名: 0
作業系統: Windows 7
軟體版本: Office 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-28
最後登錄: 2018-11-14

39^#

發表於 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"欄可不用逐筆資料自動換列只要調整欄寬就好

TOP

stillfish00

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

40^#

發表於 2013-8-2 14:50 | 只看該作者

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

TOP

[發問] 請問VBA可以做到兩檔案比對後再產生另一檔案的比對結果嗎?

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]