12
返回列表 上一主題 發帖

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

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
1# 跳轉到 »
發表於 2013-7-31 20:38 | 顯示全部帖子
回復 22# happycoccolin
CAT1  資料庫原本就沒有不是嗎?

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 2013-8-1 10:01 | 顯示全部帖子
回復 24# happycoccolin
1.  所以你希望的是   有含 "-"和沒含"-"的兩個是對應到相同結果?

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

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

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
3#
發表於 2013-8-1 12:17 | 顯示全部帖子
本帖最後由 stillfish00 於 2013-8-1 12:26 編輯

回復 26# happycoccolin
先將 B_0731.xlsx "希望顯示在這欄位" 字樣刪掉儲存關閉後，再執行。
  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.   ar = Sheets(DATABASE_NAME).[A1].CurrentRegion.Value
  10.   For i = 2 To UBound(ar)
  11.     d(Replace(ar(i, DATABASE_COL), "-", "")) = ar(i, 1)
  12.   Next
  13.   
  14.   filein = Application.GetOpenFilename(Title:="選擇要比對的檔案")
  15.   If Not TypeName(filein) = "String" Then Exit Sub '取消則結束
  16.       
  17.   Application.ScreenUpdating = False
  18.   With Workbooks.Open(filein)
  19.     ar = .Sheets(1).[A1].CurrentRegion.Value
  20.     .Close False
  21.   End With
  22.   Application.ScreenUpdating = True
  23.   
  24.   ReDim Preserve ar(LBound(ar) To UBound(ar), LBound(ar, 2) To UBound(ar, 2) + 1)
  25.   For i = LBound(ar) + 1 To UBound(ar)
  26.     s = Replace(ar(i, COMPARE_COL), "-", "")
  27.     If d.exists(s) Then
  28.       ar(i, UBound(ar, 2)) = d(s)
  29.     Else
  30.       ar(i, UBound(ar, 2)) = "No Data"
  31.     End If
  32.   Next
  33.   
  34.   fileout = Application.GetSaveAsFilename(Title:="另存為新檔")
  35.   If Not TypeName(fileout) = "String" Then Exit Sub '取消則結束
  36.   
  37.   With Workbooks.Add.Sheets(1)
  38.     .[A1].Resize(UBound(ar), UBound(ar, 2)).Value = ar
  39.     .Parent.SaveAs fileout
  40.   End With

  42. End Sub
複製代碼

TOP

stillfish00

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

stillfish00

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

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
6#
發表於 2013-8-2 13:42 | 顯示全部帖子
回復 33# happycoccolin
若是產生的檔案其中一欄位太寬大可以用VBA處理讓他最大只到欄寬50(並自動換列)

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

TOP

stillfish00

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

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
8#
發表於 2013-8-2 14:50 | 顯示全部帖子
回復 39# happycoccolin
抱歉，請將 .Width 都改為 .ColumnWidth，250改為適合的欄寬(非像素)

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
9#
發表於 2013-8-15 13:15 | 顯示全部帖子
回復 42# happycoccolin
不明白你的意思，
要連表頭貼過去? 複製時一起選就好啦

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

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
10#
發表於 2013-8-15 15:32 | 顯示全部帖子
回復 44# happycoccolin
  1. Sub TEST()
  2.   Dim ar, r As Long, i As Long
  3.   Dim cIndexOld, cIndexNew, arNewHeader
  4.   Dim f
  5.   
  6.   cIndexOld = Array(2, 3, 4, 5, 7, 8)   'A檔案中要搬動的欄
  7.   cIndexNew = Array(2, 4, 21, 24, 43, 44)   '搬到B檔位置(欄號)
  8.   arNewHeader = Array("W", "R", "X", "B", "JJ", "KK") 'B檔標題名稱
  9.   
  10.   f = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="選擇來源檔案")
  11.   If Not TypeName(f) = "String" Then Exit Sub '取消則結束
  12.   
  13.   Application.ScreenUpdating = False
  14.   With Workbooks.Open(f)
  15.     With .Sheets(1)
  16.       ar = .Range("A5:H" & .[A5].CurrentRegion.Rows.Count).Value
  17.     End With
  18.     .Close False
  19.   End With
  20.   Application.ScreenUpdating = True
  21.   
  22.   r = UBound(ar)
  23.   With Workbooks.Add
  24.     With .Sheets(1)
  25.       For i = LBound(cIndexOld) To UBound(cIndexOld)
  26.         .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
  27.         .Cells(1, cIndexNew(i)).Value = arNewHeader(i)
  28.       Next
  29.     End With
  30.    
  31.     If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
  32.       f = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
  33.       If Not TypeName(f) = "String" Then Exit Sub '取消則結束
  34.       .SaveAs f, FileFormat:=xlWorkbookDefault
  35.     End If
  36.   End With
  37. End Sub
複製代碼

TOP

        靜思自在 : 能付出愛心就是福，能消除煩惱就是慧。
12
返回列表 上一主題