123456
返回列表 上一主題 發帖

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

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

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

stillfish00

帖子
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 
34#
發表於 2013-8-2 12:53 | 只看該作者
回復 32# stillfish00


    哈囉∼stillfish00

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

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

stillfish00

帖子
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
上傳的例子，盡量保留原本資料的特性(如:是否含標頭、是否有空白、是否會有重複項等等)，才會比較符合實際想要的結果。
  1. Sub TEST()
  2.   Const DATABASE_NAME = "A" '資料庫工作表名稱
  3.   Const DATABASE_COL = 5  'E欄
  4.   Const COMPARE_COL = 11  'K欄
  5.   
  6.   Dim d, ar, filein, fileout, s As String, i As Long
  7.   
  8.   Set d = CreateObject("scripting.dictionary")
  9.   With Sheets(DATABASE_NAME)
  10.     ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
  11.   End With
  12.   For i = 2 To UBound(ar)
  13.     s = Replace(ar(i, DATABASE_COL), "-", "")
  14.     If s <> "" Then
  15.       If d.exists(s) Then
  16.         d(s) = d(s) & "," & ar(i, 1)
  17.       Else
  18.         d(s) = ar(i, 1)
  19.       End If
  20.     End If
  21.   Next
  22.   
  23.   filein = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇要比對的檔案")
  24.   If Not TypeName(filein) = "String" Then Exit Sub '取消則結束
  25.       
  26.   Application.ScreenUpdating = False
  27.   With Workbooks.Open(filein).Sheets(1)
  28.     ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
  29.     .Parent.Close False
  30.   End With
  31.   Application.ScreenUpdating = True
  32.   
  33.   ReDim Preserve ar(LBound(ar) To UBound(ar), LBound(ar, 2) To UBound(ar, 2) + 1)
  34.   For i = LBound(ar) + 1 To UBound(ar)
  35.     If ar(i, COMPARE_COL) <> "" Then
  36.       s = Replace(ar(i, COMPARE_COL), "-", "")
  37.       If d.exists(s) Then
  38.         ar(i, UBound(ar, 2)) = d(s)
  39.       Else
  40.         ar(i, UBound(ar, 2)) = "No Data"
  41.       End If
  42.     End If
  43.   Next
  44.   
  45.   With Workbooks.Add
  46.     Application.ScreenUpdating = False
  47.     With .Sheets(1).[A1].Resize(UBound(ar), UBound(ar, 2))
  48.       .Value = ar
  49.       .Font.Name = "Verdana"  '字體名稱
  50.       .Font.Size = 14 '字體大小
  51.       .Borders.LineStyle = xlContinuous '框線
  52.       .EntireColumn.AutoFit '調整欄寬
  53.       
  54.       .Rows(1).Interior.Color = 12567966  '標頭顏色
  55.       .Rows(1).Font.Bold = True  '標頭粗體字
  56.     End With
  57.     Application.ScreenUpdating = True
  58.    
  59.     If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
  60.       fileout = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
  61.       If Not TypeName(fileout) = "String" Then Exit Sub '取消則結束
  62.       .SaveAs fileout, FileFormat:=xlWorkbookDefault
  63.     End If
  64.   End With
  65. End Sub
複製代碼

TOP

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

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
30#
發表於 2013-8-2 10:12 | 只看該作者
回復 29# happycoccolin
  1. Sub TEST()
  2.   Const DATABASE_NAME = "A" '資料庫工作表名稱
  3.   Const DATABASE_COL = 5  'E欄
  4.   Const COMPARE_COL = 11  'K欄
  5.   
  6.   Dim d, ar, filein, fileout, s, i As Long
  7.   
  8.   Set d = CreateObject("scripting.dictionary")
  9.   With Sheets(DATABASE_NAME)
  10.     ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
  11.   End With
  12.   For i = 2 To UBound(ar)
  13.     d(Replace(ar(i, DATABASE_COL), "-", "")) = ar(i, 1)
  14.   Next
  15.   
  16.   filein = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇要比對的檔案")
  17.   If Not TypeName(filein) = "String" Then Exit Sub '取消則結束
  18.       
  19.   Application.ScreenUpdating = False
  20.   With Workbooks.Open(filein).Sheets(1)
  21.     ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
  22.     .Parent.Close False
  23.   End With
  24.   Application.ScreenUpdating = True
  25.   
  26.   ReDim Preserve ar(LBound(ar) To UBound(ar), LBound(ar, 2) To UBound(ar, 2) + 1)
  27.   For i = LBound(ar) + 1 To UBound(ar)
  28.     s = Replace(ar(i, COMPARE_COL), "-", "")
  29.     If d.exists(s) Then
  30.       ar(i, UBound(ar, 2)) = d(s)
  31.     Else
  32.       ar(i, UBound(ar, 2)) = "No Data"
  33.     End If
  34.   Next
  35.   
  36.   With Workbooks.Add
  37.     Application.ScreenUpdating = False
  38.     With .Sheets(1).[A1].Resize(UBound(ar), UBound(ar, 2))
  39.       .Value = ar
  40.       .Font.Name = "Verdana"  '字體名稱
  41.       .Font.Size = 14 '字體大小
  42.       .Borders.LineStyle = xlContinuous '框線
  43.       .EntireColumn.AutoFit '調整欄寬
  44.       
  45.       .Rows(1).Interior.Color = 12567966  '標頭顏色
  46.       .Rows(1).Font.Bold = True  '標頭粗體字
  47.     End With
  48.     Application.ScreenUpdating = True
  49.    
  50.     If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
  51.       fileout = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
  52.       If Not TypeName(fileout) = "String" Then Exit Sub '取消則結束
  53.       .SaveAs fileout, FileFormat:=xlWorkbookDefault
  54.     End If
  55.   End With
  56. End Sub
複製代碼

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
29#
發表於 2013-8-1 16:21 | 只看該作者
回復 27# stillfish00


    哈囉~~stillfish00 ~~^^

剛剛試過OK~

但是有幾個問題

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

ABC_0801.zip (30.21 KB)

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

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


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

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
28#
發表於 2013-8-1 12:52 | 只看該作者
回復 27# stillfish00


    謝謝stillfish00~~~~

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

TOP

        靜思自在 : 我們最大的敵人不是別人．可能是自己。
123456
返回列表 上一主題