同一工作簿中的多个工作表合并到一个工作表的代码（通用代码）

lsc900707

lrh788 发表于 2018-3-25 10:27
合并表中有身份证号，用此代码合并后无法全显示，现需要文本格式

上传附件吧，磨磨唧唧的。

1249994139

如果身份证号码是存入在B列时，在数组数据写入工作表前加上这句
Range("b:b").NumberFormatLocal = "@"

lsc900707

lrh788 发表于 2018-3-25 10:27
合并表中有身份证号，用此代码合并后无法全显示，现需要保原表格式

没有附件，不知道你的身份证号在哪一列。你自己处理吧。

lrh788

lsc900707 发表于 2018-3-26 11:17
没有附件，不知道你的身份证号在哪一列。你自己处理吧。

加到代码的哪个地方

lrh788

Sub 合并当前工作簿下的所有工作表6()

Application.ScreenUpdating = False '禁用屏幕刷新，以加快运行速度。

For j = 1 To Sheets.Count '对于所有的工作表，从表1开始，直到最后一个工作表，逐个运行下面的程序（判断程序）

If Sheets(j).Name <> ActiveSheet.Name Then '对于任意一个（第 i 个），如果它的工作表名，不是当前工作表名，那么，运行下面的程序

na = Sheets(j).Name

    If na = "表1"" Then Sheets(j).UsedRange.Copy NewSheet.Cells([a65536].End(xlUp).Row + 1, 1) '将表1已使用区域复制到新表中

    If na <> "表1" Then

        Sheets(j).UsedRange.Offset(3, 0).Copy NewSheet.Cells([a65536].End(xlUp).Row + 1, 1) '将其他表的已使用区域从第三开始复制到新表中


'复制第 i 个工作表的所有有数据的单元格，并粘贴到当前工作表的A列的第一个空单元格

End If '结束判断程序
End If

Next '下一个循环（即下一个工作表）

Range("B1").Select '选择当前工作表的B1单元格

Application.ScreenUpdating = True '刷新屏幕

MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示" '调用系统对话框，并提示："当前工作簿下的全部工作表已经合并完毕！"
End Sub

lrh788

以上代码运行出错，请大神修改并简化！

lrh788

Sub 合并当前工作簿下的所有工作表()

Application.ScreenUpdating = False

For Each sh In ActiveWorkbook.Worksheets

    If sh.Name = "合并" Then

        Application.DisplayAlerts = False

        sh.Delete

        Application.DisplayAlerts = True

        Exit For

    End If

Next

Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "合并"

Dim xc As Long

xc = 1

For Each sh In ActiveWorkbook.Worksheets

With sh

    If .Name <> "合并" Then

               x = .UsedRange.Rows.Count

           .Rows("1:" & x).Copy Sheets("合并").Rows(xc & ":" & xc)

           xc = xc + x

    End If

End With

Next

Sheets("合并").Range("a1").Select

Application.ScreenUpdating = True

MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"

End Sub

lrh788

Sub 同薄多表合并()
    Dim i As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheets("合并").Delete
    Sheets(1).Copy Before:=Sheets(1)
    With ActiveSheet
        .Name = "合并"
        .[a1].CurrentRegion.Offset(.[a1].CurrentRegion.Rows.Count - 4).Clear
        For i = 3 To Sheets.Count
            Sheets(i).Rows("4:" & Sheets(i).[a1].CurrentRegion.Rows.Count - 4).Copy .Cells(.[a1].CurrentRegion.Rows.Count + 1, 1)'Rows("4:"除表一外其他表从第三行开始合并。
        Next
    End With
    Application.ScreenUpdating = True
End Sub

lrh788

Sub hz()
   Set NewSheet = Sheets.Add(Type:=xlWorksheet) '生成一个新表
   Sheets(NewSheet.Index).Move Before:=Sheets(1) '将此新表移动到最前面
   For i = 2 To Worksheets.Count
    na = Sheets(i).Name
    If na = "表一" Then Sheets(i).UsedRange.Copy NewSheet.Cells([a65536].End(xlUp).Row + 1, 1)
    If na = "表二" Or na = "表三" Or na = "表四" Then
        Sheets(i).UsedRange.Offset(2, 0).Copy NewSheet.Cells([a65536].End(xlUp).Row + 1, 1)
    End If
   Next i
   MsgBox "合并完成"
End Sub

chenjunfu2018

lsc900707 发表于 2018-3-24 17:41
论坛里有很多实例可供参考！
提问时要提供必要的附件！

大侠帮忙看一下http://club.excelhome.net/thread-1408051-1-1.html