求vba能手帮忙改下只复制工作薄的第一个！

453187998

       这段代码也是在我们论坛上高手写的，作用是把多个工作薄合并成一个工作薄中的不同工作表，但是我只合并工作薄中的第一个也就是sheet1，这段代码是全部三个都复制过去了，因为只有第一个SHEET1有内容，别的没有，也就不需要了，代码如下，还望高手不吝赐教：[/size]
Sub CombineWorkbooks()
    Dim strFileName As String
    Dim wb As Workbook
    Dim ws As Object

    '包含工作簿的文件夹,可根据实际修改
    Const strFileDir As String = "D:\示例\数据记录\"

    Application.ScreenUpdating = False

    Set wb = Workbooks.Add(xlWorksheet)
    strFileName = Dir(strFileDir & "*.xls*")

    Do While strFileName <> vbNullString
        Dim wbOrig As Workbook
        Set wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
        strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29)

        For Each ws In wbOrig.Sheets
            ws.Copy After:=wb.Sheets(wb.Sheets.Count)
            If wbOrig.Sheets.Count > 1 Then
                wb.Sheets(wb.Sheets.Count).Name = strFileName & ws.Index
            Else
                wb.Sheets(wb.Sheets.Count).Name = strFileName
            End If
        Next

        wbOrig.Close SaveChanges:=False

        strFileName = Dir

    Loop

    Application.DisplayAlerts = False
    wb.Sheets(1).Delete
    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    Set wb = Nothing

End Sub

[ 本帖最后由 453187998 于 2011-4-13 08:22 编辑 ]

doitbest

Sub CombineWorkbooks()
    Dim strFileName As String
    Dim wb As Workbook
    Dim ws As Object
    '包含工作簿的文件夹,可根据实际修改
    Const strFileDir As String = "D:\示例\数据记录\"
    Application.ScreenUpdating = False
    Set wb = Workbooks.Add(xlWorksheet)
    strFileName = Dir(strFileDir & "*.xls*")
    Do While strFileName <> vbNullString
        Dim wbOrig As Workbook
        Set wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
        strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29)
                    wbOrig.sheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
                    wb.Sheets(wb.Sheets.Count).Name = strFileName
                   wbOrig.Close SaveChanges:=False
        strFileName = Dir
    Loop
    Application.DisplayAlerts = False
    wb.Sheets(1).Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set wb = Nothing
End Sub

453187998

谢谢楼上兄台，但是我运行后出现下面的提示：工作薄中至少有一张打可视工作表，进行调试后这一行是黄色的：
wb.Sheets(1).Delete
还望兄台指教！

doitbest

没有附件，试着改了一下
Sub CombineWorkbooks()
    Dim strFileName As String
    Dim wb As Workbook
    Dim ws As Object
    '包含工作簿的文件夹,可根据实际修改
    Const strFileDir As String = "D:\示例\数据记录\"
    Application.ScreenUpdating = False
    Set wb = Workbooks.Add(xlWorksheet)
    strFileName = Dir(strFileDir & "*.xls*")
    Do While strFileName <> vbNullString
        Dim wbOrig As Workbook
        Set wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
        strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29)
                    wbOrig.sheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
                    wb.Sheets(wb.Sheets.Count).Name = strFileName
                   wbOrig.Close SaveChanges:=False
        strFileName = Dir
    Loop
    Application.DisplayAlerts = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set wb = Nothing
End Sub

453187998

感谢楼上，可以了，能不能把自定义的目录改成当前文件夹，这样就省得每次更改它了！

doitbest

Sub CombineWorkbooks()
    Dim strFileName As String
    Dim wb As Workbook
    Dim ws As Object
  strFileDir＝thisworkbook.path &  "\"
    Application.ScreenUpdating = False
    Set wb = Workbooks.Add(xlWorksheet)
    strFileName = Dir(strFileDir & "*.xls*")
    Do While strFileName <> vbNullString
        Dim wbOrig As Workbook
        Set wbOrig = Workbooks.Open(Filename:=strFileDir & strFileName, ReadOnly:=True)
        strFileName = Left(Left(strFileName, Len(strFileName) - 4), 29)
                    wbOrig.sheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
                    wb.Sheets(wb.Sheets.Count).Name = strFileName
                   wbOrig.Close SaveChanges:=False
        strFileName = Dir
    Loop
    Application.DisplayAlerts = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set wb = Nothing
End Sub

453187998

真是太感谢你了，我刚开始学VBA，呵呵，还处于学步阶段，感激不尽！