使用VAB按鈕完成資料

koala2099

VAB我在還學習中，所以不是很懂
但急迫在工作中(每天)使用頻繁只好上來求救，請求會的大大幫我

想使用VAB按鈕完成資料

luhpro

回復 1# koala2099
all-a.zip (25.81 KB)

下載次數: 9

2013-10-30 22:58

1. Private Sub cbLdData_Click()
   
2.   Dim iI%
   
3.   Dim sSh$(0 To 1)
   
4.   Dim lRow&, lRows&
   
5.   Dim vFs, vF
   
6.   
   
7.   sSh(0) = "s"
   
8.   sSh(1) = "e"
   
9.   For iI = 0 To 1
   
10.     With Sheets(sSh(iI))
    
11.       .Activate
    
12.       .Cells.ClearContents
    
13. 
    
14.       Set vFs = CreateObject("Scripting.FileSystemObject")
    
15.       Set vF = vFs.OpenTextFile(ThisWorkbook.Path & "\" & sSh(iI) & ".csv", 1, -2) ' 使用系統預設格式開啟唯讀文字檔案
    
16.       lRow = 1
    
17.       Do While Not vF.AtEndOfStream
    
18.         With .Cells(lRow, 1)
    
19.           .Value = vF.readline
    
20.           .TextToColumns Comma:=True
    
21.         End With
    
22.         lRow = lRow + 1
    
23.       Loop
    
24.       vF.Close
    
25.       .Range(.[A2], .[B2]).Insert shift:=xlShiftDown
    
26.       lRow = 2
    
27.       lRows = 2
    
28.       Do While .Cells(lRows, 3) <> ""
    
29.         If .Cells(lRows, 1) <> "" Then
    
30.           .Rows(lRows).Cut
    
31.           .Cells(lRow, 1).Insert
    
32.           lRow = lRow + 1
    
33.         End If
    
34.         lRows = lRows + 1
    
35.       Loop
    
36. On Error GoTo LdDataErr
    
37.       .[A1].SortSpecial key1:=.[A1], Header:=xlYes
    
38.       lRows = 2
    
39.       Do While .Cells(lRows, 1) <> ""
    
40.         lRows = lRows + 1
    
41.       Loop
    
42.       .Rows(lRows & ":" & Rows.Count).Delete
    
43.     End With
    
44.   Next iI
    
45. On Error GoTo 0
    
46. Exit Sub
    
47.   
    
48. LdDataErr:
    
49.   Select Case Err.Number
    
50.     Case 1004
    
51.       Resume Next
    
52.     Case Else
    
53.       MsgBox "發生錯誤, 錯誤代碼 : " & Err.Number & "  ,錯誤原因 : " & Err.Description
    
54.       Exit Sub
    
55.   End Select
    
56. End Sub

複製代碼

koala2099

回復 2# luhpro


    :victory: 哇~~~好感動唷!以後工作可以加快許多了，非常謝謝您:loveliness:

可否在請教若檔案S及E是.xls，單純只要把S.xls工作表S、E.xls工作表E內的資料
分別複製到ALL.xls工作表S及E又該如何處理
(有時會有3~5個.xls的工作表)要複製到ALL原有工作表裡
因為ALL.xls裡我設有一個SUMIF統計全部數據表格
有在網路上找到都是新增新的工作表
不是把資料覆製到我原有工作表裡
所以我用SUMIF的連結全用不上又要重連
可否再請您幫幫我:$

luhpro

回復 3# koala2099

1. Sub nn()
   
2.   Dim iI%
   
3.   Dim sSh$(0 To 1)
   
4. 
   
5.   sSh(0) = "S"
   
6.   sSh(1) = "E"
   
7.   For iI = 0 To 1
   
8.     With Workbooks.Open(ThisWorkbook.Path & "\" & sSh(iI) & ".xls")
   
9.       .Sheets(sSh(iI)).Cells.Copy Me.Parent.Sheets(sSh(iI)).[A1]
   
10.       .Close SaveChanges:=False
    
11.     End With
    
12.   Next iI
    
13. End Sub

複製代碼

註 : 1. 程式要與 E.xls(內有 Sheets("E")) 及 S.xls(內有 Sheets("S")) <- 此即要 Copy 的資料Sheet 兩個檔案放在同個目錄下.
      2. 在上述程式所在的檔案中,S 與 E 兩個 Sheet 必須存在, 否則會發生錯誤.
      3. 請留意 -  在上述程式所在的檔案中的 S 與 E 兩個 Sheet 的所有資料會全部被覆蓋掉.
      4. 如果每次都要複製到同一個 Sheet 內, 只要改第 9 行:
      .Sheets(sSh(iI)).Cells.Copy Me.Parent.Sheets("目的Sheet的名稱")).[A1]

koala2099

回復 4# luhpro


謝謝~問題是解決了!
只是有些不便，因為下載的資料Sheets名不同
還需先一一開啟檔案將 E.xls及S.xls(內Sheets重新命名為("E")) 、 S.xls(內 Sheets重新命名為("S")) ....
有時要匯E.xls、S.xls、A.xls、B.xls、C.xls....  ;P
本想從XML資料匯入再按右鍵重新整理，只是不知道為什麼所匯入的資料是[文字]非[數據]導致SUMIF無法加總
:dizzy: 所以都用手動一個一個複製貼上值
非常謝謝您的幫忙~辛苦了3Q^^

luhpro

回復 5# koala2099
如果確定目的檔案都很單純只有一個 Sheet 那第 9 行可以改成 :

.Sheets(1).Cells.Copy Me.Parent.Sheets(sSh(iI)).[A1]

即可.

koala2099

回復 6# luhpro
順利解決了  非常謝謝您的幫忙，讓我這菜卡能更順利完成工作~謝謝^^
Sub A()
  Dim iI%
  Dim sSh$(0 To 2)

  sSh(0) = "S"
  sSh(1) = "T"
  sSh(2) = "E"

    For iI = 0 To 2
    With Workbooks.Open(ThisWorkbook.Path & "\" & sSh(iI) & ".xls")
        .Sheets(1).Cells.Copy ThisWorkbook.Sheets(sSh(iI)).[A1]
      .Close SaveChanges:=False
    End With
  Next iI
  
End Sub
另其中有檔案是.csv參雜在裡面咧??