123456
返回列表 上一主題 發帖

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

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 
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 
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

帖子
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

帖子
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(並自動換列)這一類的設定嗎?
  1. Sub TEST()
  2.   Const DATABASE_NAME = "A" '資料庫工作表名稱
  3.   Const DATABASE_COL = 5  'E欄
  4.   Const COMPARE_COL = 11  'K欄
  5.   
  6.   
  7.   Dim d, ar, filein, fileout, s As String, i As Long
  8.   
  9.   Set d = CreateObject("scripting.dictionary")
  10.   With Sheets(DATABASE_NAME)
  11.     ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
  12.   End With
  13.   For i = 2 To UBound(ar)
  14.     s = Replace(ar(i, DATABASE_COL), "-", "")
  15.     If s <> "" Then
  16.       If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
  17.       d(s)(ar(i, 1)) = ""   '第二層字典，用來篩選掉重複的A欄值
  18.     End If
  19.   Next
  20.   
  21.   filein = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇要比對的檔案")
  22.   If Not TypeName(filein) = "String" Then Exit Sub '取消則結束
  23.       
  24.   Application.ScreenUpdating = False
  25.   With Workbooks.Open(filein).Sheets(1)
  26.     ar = .[A1].CurrentRegion.Resize(.Cells(.Rows.Count, "A").End(xlUp).Row).Value
  27.     .Parent.Close False
  28.   End With
  29.   Application.ScreenUpdating = True
  30.   
  31.   ReDim Preserve ar(LBound(ar) To UBound(ar), LBound(ar, 2) To UBound(ar, 2) + 1)
  32.   For i = LBound(ar) + 1 To UBound(ar)
  33.     If ar(i, COMPARE_COL) <> "" Then
  34.       s = Replace(ar(i, COMPARE_COL), "-", "")
  35.       If d.exists(s) Then
  36.         ar(i, UBound(ar, 2)) = Join(d(s).keys, vbLf)
  37.       Else
  38.         ar(i, UBound(ar, 2)) = "No Data"
  39.       End If
  40.     End If
  41.   Next
  42.   
  43.   With Workbooks.Add
  44.     Application.ScreenUpdating = False
  45.     With .Sheets(1).[A1].Resize(UBound(ar), UBound(ar, 2))
  46.       .Value = ar
  47.       .Font.Name = "Verdana"  '字體名稱
  48.       .Font.Size = 14 '字體大小
  49.       .Borders.LineStyle = xlContinuous '框線
  50.       .EntireColumn.AutoFit '調整欄寬
  51.       
  52.       .Rows(1).Interior.Color = 12567966  '標頭顏色
  53.       .Rows(1).Font.Bold = True  '標頭粗體字
  54.       
  55.       '欄寬限制及自動換行
  56.       With .Columns("F")
  57.         If .Width > 250 Then
  58.           .Width = 250
  59.           .WrapText = True
  60.         End If
  61.       End With
  62.       With .Columns("M")
  63.         If .Width > 250 Then
  64.           .Width = 250
  65.           .WrapText = True
  66.         End If
  67.       End With
  68.     End With
  69.     Application.ScreenUpdating = True
  70.    
  71.     If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
  72.       fileout = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
  73.       If Not TypeName(fileout) = "String" Then Exit Sub '取消則結束
  74.       .SaveAs fileout, FileFormat:=xlWorkbookDefault
  75.     End If
  76.   End With
  77. 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

帖子
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

        靜思自在 : 地上種了菜，就不易長草；心中有善，就不易生惡。
123456
返回列表 上一主題