求助Excel巨集

我要如何將資料夾內所有檔案(副檔名為"csv")的部份欄位資料,匯出至一個Data.xls中,如第一個檔案的A3、B5、B6、B7欄位要匯出到Data.xls的A2、B2、C2及D2欄位,第二個檔案的A3、B5、B6、B7欄位要匯出到Data.xls的A3、B3、C3及D3,以下依此類推~~

Update:

謝謝小沙魚大大,您的巨集解決了我的困擾;另外,請教一下,如果還有相關巨集的問題,可以再請教您嗎?

2 Answers

Rating
  • Favorite Answer

    在data.xls,製作以下模組(執行main_process即可得到結果)

    Public gm_origin_path As String

    Public gm_csv() As String

    Public gm_find_string As String

    Public gm_thisworkbook_name As String

    Public gm_sheet_name As String

    Public gm_data_count As Double

    Public Sub main_process()

    Call read_setup

    Call find_csv

    If UBound(gm_csv) = 0 Then

    Call MsgBox("該目錄下:" & gm_origin_path & ",無csv檔案", vbCritical)

    Exit Sub

    End If

    Call open_csv

    End Sub

    Private Sub read_setup()

    Dim i As Integer

    gm_origin_path = ThisWorkbook.Path & "\"

    gm_thisworkbook_name = ThisWorkbook.Name

    gm_sheet_name = ActiveSheet.Name

    gm_data_count = 0

    End Sub

    Private Sub find_csv() '讀取csv檔名,將csv檔名放入gm_csv()內

    Dim i As Integer

    Dim wk_file_name As String

    Erase gm_csv

    ReDim gm_csv(0)

    wk_file_name = Dir(gm_origin_path)

    Do Until wk_file_name = ""

    '此處判斷式,可加入判斷檔名,可變性比較大 (雖然在第一個dir 可以指定只搜尋.csv檔案)

    If Right(wk_file_name, 4) = ".csv" Then

    ReDim Preserve gm_csv(UBound(gm_csv) + 1)

    gm_csv(UBound(gm_csv)) = wk_file_name

    End If

    wk_file_name = Dir

    Loop

    End Sub

    Private Sub open_csv() '開啟csv檔案

    Dim wk_workbook As Workbook

    Dim i As Integer

    On Error GoTo fail_exit

    Excel.Application.DisplayAlerts = False

    Excel.Application.Visible = False

    For i = 1 To UBound(gm_csv)

    wk_process_no = 1

    Set wk_workbook = Workbooks.Open(gm_origin_path & gm_csv(i))

    wk_process_no = 2

    wk_workbook.Activate

    Call deal_sheets(wk_workbook)

    Call wk_workbook.Close

    Next i

    Set wk_workbook = Nothing

    Excel.Application.DisplayAlerts = True

    Excel.Application.Visible = True

    Exit Sub

    fail_exit:

    If wk_process_no <> 1 Then Call wk_workbook.Close

    Set wk_workbook = Nothing

    Excel.Application.DisplayAlerts = True

    Excel.Application.Visible = True

    Call MsgBox(Err.Description, vbCritical)

    End Sub

    2010-01-28 15:58:16 補充:

    Private Sub deal_sheets(lk_workbook As Workbook)

    gm_data_count = gm_data_count + 1

    Workbooks(gm_thisworkbook_name).Sheets(gm_sheet_name).Range("a" & CStr(gm_data_count + 1)) = Range("A3").Value

    2010-01-28 15:58:25 補充:

    Workbooks(gm_thisworkbook_name).Sheets(gm_sheet_name).Range("b" & CStr(gm_data_count + 1)) = Range("b5").Value

    Workbooks(gm_thisworkbook_name).Sheets(gm_sheet_name).Range("c" & CStr(gm_data_count + 1)) = Range("b6").Value

    2010-01-28 15:58:29 補充:

    Workbooks(gm_thisworkbook_name).Sheets(gm_sheet_name).Range("d" & CStr(gm_data_count + 1)) = Range("b7").Value

    End Sub

    2010-01-28 15:58:58 補充:

    因字數限制,所以分成很多段po

    2010-01-29 00:14:49 補充:

    可以啊 ^ ^

  • 5 years ago

    我本來從沒遇到過修NAS修硬碟和隨身碟要資料救援,一開始也跟大家一樣總是問價格到處比價,因為不懂,凡事都從價格,考量,輕言聽信朋友介紹比較便宜一家,找錯家之後痛苦尾隨而來,以下省略500字........,後來自己上網找資料救援找到硬碟醫院,和他們經理溝通之後給我正確觀念,這是妳寶貴的資料,妳要考慮是救不救的回問題,而不是貴不貴問題,如果重要請找對人搶救NAS資料硬碟救援才能恢復你的NAS中多顆的硬碟資料

    http://www.datamaster.com.tw/

Still have questions? Get your answers by asking now.