happycoccolin

回復 10# GBKEE


    謝謝板大!!!!!!

但是偵錯目前停在
    With Workbooks("C.xlsx").Sheets(1)

是不是若我不指定新檔案的檔名就不會有錯誤呢?

應該是說比對完成後跑出的檔案由使用者自定義名稱

抱歉問題很多

我附上檔案給您參考
ABC.xlsm為資料庫
B.xlsx為欲比對檔案
希望比對後產生一新檔案(由使用者自定義名稱另存新檔)
ABC (2).zip (22.42 KB)

下載次數: 6

2013-7-26 14:16

很高興板大願意解惑~^^

GBKEE

回復 11# happycoccolin

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim d As Object, i As Variant, S  As Variant, Wb As Workbook, Wb_Name As String
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With Application.FileDialog(msoFileDialogFilePicker) 'FileDialog :表檔案對話方, msoFileDialogFilePicker(參數):選取檔案
   
6.         .AllowMultiSelect = False                        '允許使用者從檔案對話方塊選取多個檔案=False
   
7.          If .Show = False Then MsgBox "沒有選擇檔案 !!!":   Exit Sub
   
8.          Set Wb = Workbooks.Open(.SelectedItems(1))   '開啟指定檔案
   
9.     End With
   
10.     i = 1
    
11.     With Workbooks("A.xlsx").Sheets(1)   '
    
12.         Do While .Cells(i, "e") <> ""
    
13.             d(.Cells(i, "e").Value) = .Cells(i, "A").Value
    
14.             i = i + 1
    
15.         Loop
    
16.     End With
    
17.      i = 1
    
18.     With Wb.Sheets(1)
    
19.         Do While .Cells(i, "J") <> ""
    
20.            S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":J" & i))), ",")
    
21.            If d.Exists(.Cells(i, "J").Value) Then
    
22.                 S = S & "," & d(.Cells(i, "J").Value)
    
23.                 d(.Cells(i, "J").Value) = Split(S, ",")
    
24.            Else
    
25.                 d(.Cells(i, "J").Value) = Split(S & ",No Data", ",")
    
26.                 S = d(.Cells(i, "J").Value)
    
27.            
    
28.            End If
    
29.             i = i + 1
    
30.         Loop
    
31.         .Parent.Close False               '關閉指定檔案不存檔
    
32.     End With
    
33.     For Each i In d.keys
    
34.         If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i        '可忽略"-"的步驟
    
35.     Next
    
36.     Do
    
37.         Wb_Name = InputBox("輸入新檔名", "存檔名稱")
    
38.     Loop Until Wb_Name <> ""                             '直到有輸入字串離開迴圈
    
39.     Set Wb = Workbooks.Add(1)
    
40.     With Wb.Sheets(1)
    
41.         .Cells.Clear
    
42.         S = Application.Transpose(Application.Transpose(d.ITEMS))
    
43.         .[A1].Resize(UBound(S, 1), UBound(S, 2)) = S
    
44.     End With
    
45.     Wb.SaveAs "D:\TEST\" & Wb_Name & "XLSX"  '存檔的完整名稱
    
46. End Sub

複製代碼

happycoccolin

回復 12# GBKEE


    感謝板大的迅速回覆~~~

請問一下目前偵錯停在
Sub Ex()

我現在要怎麼處理呢?

謝謝板大的幫忙!!!!!!!

GBKEE

回復 13# happycoccolin
同一個模組中 不能有相同的程序名稱  Sub Ex()
找找看還有第2個 Sub Ex() 嗎?

happycoccolin

回復 14# GBKEE


    版大~~只有一個Ex~~~我有附檔~~>< 拜託幫忙撥空看一下好嗎~
感激不盡!!!

ABC (3).zip (40.64 KB)

下載次數: 5

2013-7-26 16:57

GBKEE

回復 15# happycoccolin
不好意思 改一下最後 Save -> SaveAs

1. Wb.SaveAs "D:\TEST\" & Wb_Name & "XLSX"  '存檔的完整名稱

複製代碼

happycoccolin

回復 16# GBKEE


    謝謝版大的幫忙~~~~

再請教一下~目前偵錯停在
With Workbooks("A.xlsx").Sheets(1)   '

因為我已經將資料庫放在ABC.xlsm裡面了

那下面這段語法是否就不用針對A.xlsx做處理呢?

i = 1
    With Workbooks("A.xlsx").Sheets(1)   '
        Do While .Cells(i, "e") <> ""
            d(.Cells(i, "e").Value) = .Cells(i, "A").Value
            i = i + 1
        Loop

GBKEE

回復 17# happycoccolin
因為我已經將資料庫放在ABC.xlsm裡面了
    With Workbooks("A.xlsx").Sheets(1)   -改一下檔名  With Workbooks("ABC.xlsm").Sheets(1)

happycoccolin

回復 18# GBKEE


    報告版大~

目前偵錯停在
Wb.SaveAs "D:\TEST\" & Wb_Name & "XLSX"  '存檔的完整名稱

可是比對結果通通都是NO DATA耶~

請見附檔
ABC3.zip (58.66 KB)

下載次數: 5

2013-7-30 10:53

GBKEE

回復 19# happycoccolin
可是比對結果通通都是NO DATA
問題在這裡

1. With Workbooks("ABC.xlsm").Sheets(1)
   
2.         '這Sheets(1) 是ABC.xlsm的第一個工作表 (MAIN)
   
3.         '是否要改成 Sheets(2) ->  第二個工作表 (A)
   
4.         Do While .Cells(i, "e") <> ""
   
5.             d(.Cells(i, "e").Value) = .Cells(i, "A").Value
   
6.             i = i + 1
   
7.         Loop
   
8.     End With

複製代碼

D:\TEST \  這資料夾是我隨意寫的,你需改為你PC中存在的資料夾