返回列表 上一主題 發帖

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

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

請問一下大師們~

目前手邊有一近五萬筆的資料庫--A資料 我們需要將手邊的B資料與之做比對

請問VBA有沒有辦法做出一個檔案 開啟後直接載入EXCEL的A檔案 與B檔案 比對後產生C檔案呢?
C檔案以B檔案格式為主 向後多加欄位"K"
K欄位內容是A檔案的A欄位

比對內容是

A檔案的E欄位 與 B檔案的J欄位比較(可忽略"-")

A檔案的格式如下
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

B檔案的格式如下
A                 B           C                       D                         E                      F                       G             H                I           J
11            XX          XX                      XX                       XX                 XX                        XX         XX            CC       DOG
12            XX          XX                      XX                       XX                 XX                        XX         XX            CC       CAT
13            XX          XX                      XX                       XX                 XX                        XX         XX            CC       CAT1
14            XX          XX                      XX                       XX                 XX                        XX         XX            CC       CAT-1
15            XX          XX                      XX                       XX                 XX                        XX         XX            CC       CAT3

比對結果希望產生C檔案
A                 B           C                       D                         E                      F                       G             H                I           J                K
11            XX          XX                      XX                       XX                 XX                        XX         XX            CC       DOG       100-1
12            XX          XX                      XX                       XX                 XX                        XX         XX            CC       CAT          100-2
13            XX          XX                      XX                       XX                 XX                        XX         XX            CC       CAT1        100-3
14            XX          XX                      XX                       XX                 XX                        XX         XX            CC       CAT-1       100-3
15            XX          XX                      XX                       XX                 XX                        XX         XX            CC       CAT3          No Data

回復 55# stillfish00


    謝謝S大~~~~~~~~~^^

只是若要跟程式結合我還是有問題~~~@@

加錯地方整個程式RUN出來是空白的.........

  r = UBound(ar)
  With Workbooks.Add
       With .Sheets(1)
      For i = LBound(cIndexOld) To UBound(cIndexOld)
        .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
      Next
      .[A1].Resize(, UBound(arNewHeader) + 1).Value = arNewHeader
      .[A1:AV10000].Font.Name = "Arial"  '字體名稱
      .[A1:AV10000].Font.Size = 10 '字體大小
      
    End With

TOP

回復 54# happycoccolin
.Cells 就代表工作表中的所有儲存格了
  1. With Workbooks.Add
  2.        With .Sheets(1).Cells
  3.           .Font.Name = "Tahoma"  '字體名稱
  4.           .Font.Size = 10 '字體大小
  5.        End With
  6. End With
複製代碼

TOP

回復 53# stillfish00


    瞭解了~~~~S大~^_____^

那若是整個sheet都要設定可以怎麼改~

我現在是這樣寫

      .[A1:AV10000].Font.Name = "Tahoma"  '字體名稱
      .[A1:AV10000].Font.Size = 10 '字體大小

TOP

回復 52# happycoccolin
要給儲存格範圍,如
With Workbooks.Add
       With .Sheets(1)
          .[A1:H1].Font.Name = "Tahoma"  '字體名稱
          .[A1:H1].Font.Size = 10 '字體大小
       End With
End With

TOP

回復 50# stillfish00


    S大~~我想加入這兩行~但是一直有錯可以幫忙看一下嗎~~~謝謝~~~~
With Workbooks.Add
       With .Sheets(1)
      .Font.Name = "Tahoma"  '字體名稱
      .Font.Size = 10 '字體大小
       End With
End With

TOP

回復 50# stillfish00


    謝S大的超快速解答~

我來多跑幾個檔案試試看~

目前有一段會有問題 我再多RUN幾個檔案看格式哪邊有不同~

.Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))

謝Stillfish00大~^________^

TOP

回復 49# happycoccolin
  1. Sub TEST()
  2.   Dim ar, r As Long, i As Long
  3.   Dim cIndexOld, cIndexNew, arNewHeader
  4.   Dim f, findTitle
  5.   
  6.   cIndexOld = Array(2, 3, 4, 5, 7, 8)   'A檔案中要搬動的欄
  7.   cIndexNew = Array(2, 4, 21, 24, 43, 44)   '搬到B檔位置
  8.   arNewHeader = Array("Q", "W", "E", "R", "T", "Y", "U", "I") '自己填全部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.       Set findTitle = .Cells.Find("Item", , xlValues, xlWhole, xlByRows, xlNext)  '找標題 Item
  17.       If findTitle Is Nothing Then MsgBox "找不到標題": Exit Sub
  18.       
  19.       With findTitle.CurrentRegion
  20.         ar = .Parent.Range(findTitle, .Cells(.Rows.Count, .Columns.Count)).Value
  21.       End With
  22.     End With
  23.     .Close False
  24.   End With
  25.   Application.ScreenUpdating = True
  26.   
  27.   r = UBound(ar)
  28.   With Workbooks.Add
  29.     With .Sheets(1)
  30.       For i = LBound(cIndexOld) To UBound(cIndexOld)
  31.         .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
  32.       Next
  33.       .[A1].Resize(, UBound(arNewHeader) + 1).Value = arNewHeader
  34.     End With
  35.    
  36.     If MsgBox("是否要儲存檔案?", vbYesNo) = vbYes Then
  37.       f = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
  38.       If Not TypeName(f) = "String" Then Exit Sub '取消則結束
  39.       .SaveAs f, FileFormat:=xlWorkbookDefault
  40.     End If
  41.   End With
  42. End Sub
複製代碼

TOP

回復 48# stillfish00


    哈囉S大~我試過了~~~感激不盡~

想請問一下若是我要跑資料從B5開始的 是要修改哪邊呢?

還是可以用判斷TITLE這種方式處理嗎?

EX:若TITLE(B4)是"Item"就從下一格(B5)開始取資料 一類的

不好意思..又以一般人的想法來提問~@@

謝謝S大的耐心與幫忙

TOP

本帖最後由 stillfish00 於 2013-8-15 17:49 編輯

回復 46# happycoccolin
若有的檔案是B5欄開始有的是B6欄開始 可以怎麼判斷?

不知道,
而且你的A_0814.xlsx檔案挺怪的!
[A4]儲存格明明沒文字(也沒有不可見字元),卻又不是空白儲存格(尋找>特殊目標>空白,不會找到)
用Ctrl+上下也都會跳過。

第一次遇到這種情形~

若是新表格所有欄位都要有TITLE 可以都填上嗎~

改一下
  1.   arNewHeader = Array("Q", "W", "E", "R", "T", "Y", "U", "I") '自己填上全部新標題名稱
複製代碼
還有這邊
  1.     With .Sheets(1)
  2.       For i = LBound(cIndexOld) To UBound(cIndexOld)
  3.         .Cells(1, cIndexNew(i)).Resize(r).Value = Application.WorksheetFunction.Index(ar, 0, cIndexOld(i))
  4.       Next
  5.       .[A1].Resize(, UBound(arNewHeader) + 1).Value = arNewHeader
  6.     End With
複製代碼

TOP

        靜思自在 : 為人處世要小心細心,但不要「小心眼」。
返回列表 上一主題