【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