- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
12#
發表於 2013-7-26 14:38
| 只看該作者
本帖最後由 GBKEE 於 2013-7-26 17:05 編輯
回復 11# happycoccolin - Option Explicit
- Sub Ex()
- Dim d As Object, i As Variant, S As Variant, Wb As Workbook, Wb_Name As String
- Set d = CreateObject("scripting.dictionary")
- With Application.FileDialog(msoFileDialogFilePicker) 'FileDialog :表檔案對話方, msoFileDialogFilePicker(參數):選取檔案
- .AllowMultiSelect = False '允許使用者從檔案對話方塊選取多個檔案=False
- If .Show = False Then MsgBox "沒有選擇檔案 !!!": Exit Sub
- Set Wb = Workbooks.Open(.SelectedItems(1)) '開啟指定檔案
- End With
- 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
- End With
- i = 1
- With Wb.Sheets(1)
- Do While .Cells(i, "J") <> ""
- S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":J" & i))), ",")
- If d.Exists(.Cells(i, "J").Value) Then
- S = S & "," & d(.Cells(i, "J").Value)
- d(.Cells(i, "J").Value) = Split(S, ",")
- Else
- d(.Cells(i, "J").Value) = Split(S & ",No Data", ",")
- S = d(.Cells(i, "J").Value)
-
- End If
- i = i + 1
- Loop
- .Parent.Close False '關閉指定檔案不存檔
- End With
- For Each i In d.keys
- If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i '可忽略"-"的步驟
- Next
- Do
- Wb_Name = InputBox("輸入新檔名", "存檔名稱")
- Loop Until Wb_Name <> "" '直到有輸入字串離開迴圈
- Set Wb = Workbooks.Add(1)
- With Wb.Sheets(1)
- .Cells.Clear
- S = Application.Transpose(Application.Transpose(d.ITEMS))
- .[A1].Resize(UBound(S, 1), UBound(S, 2)) = S
- End With
- Wb.SaveAs "D:\TEST\" & Wb_Name & "XLSX" '存檔的完整名稱
- End Sub
|
|
發表於 2013-7-26 14:19
| 
