Fatal编程技术网
  • vba/
  • VBA:尝试将所有工作表合并到单个工作簿中的一个新工作表中

VBA:尝试将所有工作表合并到单个工作簿中的一个新工作表中

vba excel macros

VBA:尝试将所有工作表合并到单个工作簿中的一个新工作表中,vba,excel,macros,Vba,Excel,Macros,我试图复制所有工作表，一次一张，然后粘贴到新的工作表中。这些文件来自多个第三方，因此工作表可能会有所不同。在尝试确定最后一行Lrow和最后一列Lcol时，我遇到了以下问题，因为出现了一个错误，说明对象不支持此属性或方法。我确实计划将此提交到我的工作中，因此任何有关防错或一般宏提示的帮助都将不胜感激 Sub ws_copy() Dim Lrow As Long Dim Lcol As Long Dim Pasterow As Long Dim WSCount As Integer Dim i As

我试图复制所有工作表，一次一张，然后粘贴到新的工作表中。这些文件来自多个第三方，因此工作表可能会有所不同。在尝试确定最后一行
Lrow
和最后一列
Lcol
时，我遇到了以下问题，因为出现了一个错误，说明
对象不支持此属性或方法。我确实计划将此提交到我的工作中，因此任何有关防错或一般宏提示的帮助都将不胜感激


Sub ws_copy()
Dim Lrow As Long
Dim Lcol As Long
Dim Pasterow As Long
Dim WSCount As Integer
Dim i As Integer

'On Error Resume Next
    'Application.DisplayAlerts = False
        i = Application.InputBox(prompt:="Enter the place order of first tab to be copied.", Title:="Worksheet Consolidation", Type:=1)


    If IsEmpty(i) = True Then
        Exit Sub
    Else

    If IsNumeric(i) = False Then
        MsgBox "Enter a numeric value."
    Else

    If IsNumeric(i) = True Then
         Worksheets.Add(before:=Sheets(1)).Name = "Upload"


            WSCount = Worksheets.Count

        For i = i + 1 To WSCount


        Lrow = Worksheets(i).Find("*", After:=Cells(1, 1), _
                    LookIn:=xlFormulas, _
                    Lookat:=xlPart, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

        Lcol = Worksheets(i).Find("*", After:=Cells(1, 1), _
                    LookIn:=xlFormulas, _
                    Lookat:=xlPart, _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row


    Pasterow = Lrow + 1

    Workbook.Worksheets(i).Range(Cells(1, 1), Cells(Lrow, Lcol)).Copy
    Workbook.Worksheets("Upload").Cells(Pasterow, 1).Paste



        Next i

    Else
    Exit Sub

    End If
    End If
    End If

'On Error GoTo 0
'Application.DisplayAlerts = False

End Sub



查找最后一行/列的常用方法是：


With Worksheets(i)

    Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column

End With



hth
查找最后一行/列的常用方法是：


With Worksheets(i)

    Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column

End With



hth
基于以下评论：


由于收到的文件种类繁多，我不能假设任何一列或一行都有最后一段数据

您应该了解如何使用工作表（）的
UsedRange
属性<代码>使用范围
随着更多数据输入工作表而扩展

有些人会避免使用
UsedRange
，因为如果输入了一些数据，然后将其删除，那么
UsedRange
将包含这些“空”单元格。保存工作簿时，
UsedRange
将自动更新。然而，在你的情况下，这听起来并不是一个相关的问题

例如：

Sub Test()

    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim rngSource As Range
    Dim rngTarget As Range

    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    Set rngSource = wsSource.UsedRange

    rngSource.Copy Destination:=wsTarget.Cells

End Sub
根据以下评论：

由于收到的文件种类繁多，我不能假设任何一列或一行都有最后一段数据

您应该了解如何使用工作表（）的
UsedRange
属性<代码>使用范围随着更多数据输入工作表而扩展

有些人会避免使用
UsedRange
，因为如果输入了一些数据，然后将其删除，那么
UsedRange
将包含这些“空”单元格。保存工作簿时，
UsedRange
将自动更新。然而，在你的情况下，这听起来并不是一个相关的问题

例如：

Sub Test()

    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim rngSource As Range
    Dim rngTarget As Range

    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    Set rngSource = wsSource.UsedRange

    rngSource.Copy Destination:=wsTarget.Cells

End Sub
以下是查找工作表中最后使用的行和最后使用的列的方法。它避免了
UsedRange
的问题，也避免了不知道哪一行可能有最后一行（以及哪一列可能有最后一行）的问题。适应你的目的：

Option Explicit
Sub LastRowCol()

Dim LastRow As Long, LastCol As Long

With Worksheets("sheet1") 'or any sheet
    If Application.WorksheetFunction.CountA(.Cells) > 0 Then
        LastRow = .Cells.Find(what:="*", after:=[A1], _
                    LookIn:=xlFormulas, _
                    searchorder:=xlByRows, _
                    searchdirection:=xlPrevious).Row
        LastCol = .Cells.Find(what:="*", after:=[A1], _
                    LookIn:=xlFormulas, _
                    searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

Debug.Print LastRow, LastCol

End Sub
尽管基本技术已经被长期使用，Siddarth Rout不久前发布了一个版本，添加了
COUNTA
，以解释工作表可能为空的情况，这是一个有用的补充。

以下是一种查找工作表中最后使用的行和最后使用的列的方法。它避免了
UsedRange
的问题，也避免了不知道哪一行可能有最后一行（以及哪一列可能有最后一行）的问题。适应你的目的：

Option Explicit
Sub LastRowCol()

Dim LastRow As Long, LastCol As Long

With Worksheets("sheet1") 'or any sheet
    If Application.WorksheetFunction.CountA(.Cells) > 0 Then
        LastRow = .Cells.Find(what:="*", after:=[A1], _
                    LookIn:=xlFormulas, _
                    searchorder:=xlByRows, _
                    searchdirection:=xlPrevious).Row
        LastCol = .Cells.Find(what:="*", after:=[A1], _
                    LookIn:=xlFormulas, _
                    searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

Debug.Print LastRow, LastCol

End Sub
尽管基本技术已经被长期使用，Siddarth Rout不久前发布了一个版本，添加了
COUNTA
，以解释工作表可能为空的情况，这是一个有用的补充。

如果您想将每张工作表上的数据合并到一张母版工作表中，请运行下面的脚本

Sub CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "RDBMergeSheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then

            'Find the last row with data on the DestSh
            Last = LastRow(DestSh)

            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("A1:G1")

            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If

            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look at the example below this macro
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

            'Optional: This will copy the sheet name in the H column
            DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

多工作表（）的子副本范围
将sh设置为工作表
将DestSh设置为工作表
持续时间一样长
暗拷贝As范围
应用
.ScreenUpdate=False
.EnableEvents=False
以
'删除工作表“RDBMergeSheet”（如果存在）
Application.DisplayAlerts=False
出错时继续下一步
ActiveWorkbook.Worksheets（“RDBMergeSheet”）。删除
错误转到0
Application.DisplayAlerts=True
'添加名为“RDBMergeSheet”的工作表'
设置DestSh=ActiveWorkbook.Worksheets.Add
DestSh.Name=“RDBMergeSheet”
'循环浏览所有工作表并将数据复制到DestSh
对于ActiveWorkbook.工作表中的每个sh
如果sh.Name DestSh.Name那么
'查找DestSh上包含数据的最后一行
最后一行=最后一行（DestSh）
'填写要复制的范围
设置CopyRng=sh.Range（“A1:G1”）
'测试DestSh中是否有足够的行来复制所有数据
如果Last+CopyRng.Rows.Count>DestSh.Rows.Count，则
MsgBox“Destsh中没有足够的行”
下地狱
如果结束
'如果您只想复制
'值或要复制所有内容请参见此宏下面的示例
复制，复制
带目标单元格（最后+1，“A”）
.Paste特殊XLPaste值
.Paste特殊XLPaste格式
Application.CutCopyMode=False
以
'可选：这将复制H列中的图纸名称
DestSh.Cells（Last+1，“H”）.Resize（CopyRng.Rows.Count）.Value=sh.Name
如果结束
下一个
退出主题：
应用程序。转到DestSh。单元格（1）
'自动调整DestSh工作表中的列宽
DestSh.Columns.AutoFit
应用
.ScreenUpdate=True
.EnableEvents=True
以
端接头
函数LastRow（sh作为工作表）
出错时继续下一步
LastRow=sh.Cells.Find（内容：=“*”_
之后：=sh.Range（“A1”）_
看：=xlPart_
LookIn:=xl公式_
搜索顺序：=xlByRows_
搜索方向：=xlPrevious_
MatchCase:=False）。行
错误转到0
端函数
函数LastCol（sh作为工作表）
出错时继续下一步
LastCol=sh.Cells.Find（内容：=“*”_
之后：=sh.Range（“A1”）_
看：=xlPart_
LookIn:=xl公式_
SearchOrder:=xlByColumns_
搜索方向：=xlPrevious_
MatchCase:=False）。列
错误转到0
端函数
另外，请参见l