123456
返回列表 上一主題 發帖

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

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
21# 跳轉到 »
發表於 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))

ABC (4).zip (25.4 KB)

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

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


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

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

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

請見附檔~~~謝謝~
0731.zip (23.49 KB)

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沒有被比對出來~~
附檔
0730.zip (24.12 KB)

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

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

TOP

stillfish00

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

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

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


   
哈囉~因為有這一段

比較(可忽略"-")

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

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

TOP

stillfish00

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

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

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

TOP

happycoccolin
　暱稱: NANAKO

中學生Rank: 2

帖子
72 
主題
7 
精華
0 
積分
88 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2012-6-28 
最後登錄
2018-11-14 
26#
發表於 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"欄)
      現在的寫法若填入資料是會覆蓋原本的欄位 希望能夠產生一新欄位 而不是用覆蓋寫入

TOP

stillfish00

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

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

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

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

        靜思自在 : 人生最大的成就是從失敗中站起來。
123456
返回列表 上一主題