【VBA、Excel】2018.01.25解答excel吧友問題代碼

本代碼提供一個示例

代碼功能：以當前工作薄sheet1的第一列中的數據爲名，新建工作薄（有多少列建多少工作薄），並將當前工作薄sheet2中的數據複製到新建的工作薄中；複製規則爲：當前工作薄sheet2中第k列的數據複製到第k個新建的工作薄的sheet1中

涉及知識：vba在指定目錄新建工作薄、對指定路徑中的工作薄的特定工作表進行操作

Sub test()
    Dim row, patht, pathf, temp
    Dim col As Integer
    row = 2
    col = 1
    pathf = ThisWorkbook.Path + "\" + ThisWorkbook.Name
    Do While Worksheets("sheet1").Cells(row, 1) <> ""
        patht = Create_New_Workbook(Worksheets("sheet1").Cells(row, 1))
        temp = My_Copy(col, pathf, patht)
        col = col + 1
        row = row + 1
    Loop
End Sub

Function Create_New_Workbook(WorkBookName As String) As String  '在當前文件夾內新建工作薄並返回工作薄路徑
    Application.ScreenUpdating = False
    Dim gzb As Workbook
    mypath = ThisWorkbook.Path & "\" & WorkBookName & ".xlsx"
    Set gzb = Workbooks.Add
    gzb.SaveAs mypath  '保存工作薄
    gzb.Close
    Application.ScreenUpdating = True
    Create_New_Workbook = mypath
End Function

Function My_Copy(col As Integer, f As Variant, t As Variant)
    '將f工作薄中的數據複製到t工作薄內
    Application.ScreenUpdating = False
    Dim row
    Set wbf = GetObject(f)
    Set wbt = GetObject(t)   
  For row = 1 To wbf.Worksheets("sheet2").UsedRange.Rows.Count 'wbf.Worksheets("sheet2").UsedRange.Rows.Count工作表中已經被使用的行數
         wbt.Worksheets("sheet1").Cells(row, 1) = wbf.Worksheets("sheet2").Cells(row, col)
    Next row
Windows(wbt.Name).Visible = True 'getobject獲取excel文件控制權後會以隱藏式方式打開，可以用windows(WB.NAME).visible=true方式取消隱藏
    wbt.Save
    wbt.Close
    
    Application.ScreenUpdating = True
End Function