[已解决]多sheet合并保留一个表头并增加a列，我的错在哪了

wanl01

多sheet合并保留一个表头并增加a列，我的错在哪了

为什么原表头会错位了呢？应该在B1才对
请问应该怎么修改

Sub 合并所有工作表()

Dim i As Integer, sht As Worksheet, sh AsWorksheet, bt As Integer, d As Integer

On Error Resume Next

Set sht = Sheets("可配")

If Err <> 0 Then

With Sheets.Add(before:=Sheets(1))

.Name = "可配"

End With

Else

Sheets("可配").MoveSheets(Sheets.count)

Sheets("可配").rows("2:60000").Delete

End If

For Each sh In Worksheets

If sh.Name <> "可配" Andsh.Name <> "透视汇总" Then

sh.rows("1:1").Copy Sheets("可配").[a1]

sh.UsedRange.Offset(1).Copy Sheets("可配").Cells(rows.count,2).End(xlUp).Offset(1) '拷贝数据

Sheets("可配").Cells(rows.count,1).End(xlUp).Offset(1).Resize(sh.UsedRange.rows.count - 1, 1) = sh.Name

End If

Next sh

Range("A1").Select

ActiveCell.FormulaR1C1 = "仓位"

ActiveWorkbook.Save

End Sub

最佳答案

月排行榜 / 总排行榜

france723

2017-5-5 19:32

Sub 合并所有工作表()

Dim i As Integer, sht As Worksheet, sh AsWorksheet, bt As Integer, d As Integer

On Error Resume Next

Set sht = Sheets("可配")

If Err <> 0 Then

With Sheets.Add(before:=Sheets(1))

.Name = "可配"

End With

Else

Sheets("可配").MoveSheets(Sheets.count)

Sheets("可配").rows("2:60000").Delete

End If

For Each sh In Worksheets

If sh.Name <> "可配" Andsh.Name <> "透视汇总" Then

sh.rows("1:1").Copy Sheets("可配").[a1]

Cells(1, 1).Insert Shift:=xlToRight

sh.UsedRange.Offset(1).Copy Sheets("可配").Cells(rows.count,2).End(xlUp).Offset(1) '拷贝数据

Sheets("可配").Cells(rows.count,1).End(xlUp).Offset(1).Resize(sh.UsedRange.rows.count - 1, 1) = sh.Name

End If

Next sh

Range("A1").Select

ActiveCell.FormulaR1C1 = "仓位"

ActiveWorkbook.Save

End Sub

跳转到最佳答案楼层

france723

Sub 合并所有工作表()

Dim i As Integer, sht As Worksheet, sh AsWorksheet, bt As Integer, d As Integer

On Error Resume Next

Set sht = Sheets("可配")

If Err <> 0 Then

With Sheets.Add(before:=Sheets(1))

.Name = "可配"

End With

Else

Sheets("可配").MoveSheets(Sheets.count)

Sheets("可配").rows("2:60000").Delete

End If

For Each sh In Worksheets

If sh.Name <> "可配" Andsh.Name <> "透视汇总" Then

sh.rows("1:1").Copy Sheets("可配").[a1]

Cells(1, 1).Insert Shift:=xlToRight

sh.UsedRange.Offset(1).Copy Sheets("可配").Cells(rows.count,2).End(xlUp).Offset(1) '拷贝数据

Sheets("可配").Cells(rows.count,1).End(xlUp).Offset(1).Resize(sh.UsedRange.rows.count - 1, 1) = sh.Name

End If

Next sh

Range("A1").Select

ActiveCell.FormulaR1C1 = "仓位"

ActiveWorkbook.Save

End Sub

wanl01

france723 发表于 2017-5-5 19:32
Sub 合并所有工作表()Dim i As Integer, sht As Worksheet, sh AsWorksheet, bt As Integer, d As IntegerO ...

不行啊。总表的标题还是错的，现在连分表都错位了~~~~

france723

wanl01 发表于 2017-5-5 20:20
不行啊。总表的标题还是错的，现在连分表都错位了~~~~

分表错位? 你说的总表最终想达到的不是这样的?

wanl01

france723 发表于 2017-5-5 20:36
分表错位? 你说的总表最终想达到的不是这样的?

是呀，为什么我不可以的呢，~

france723

wanl01 发表于 2017-5-5 20:41
是呀，为什么我不可以的呢，~
分表
总表

你的附件就是你操作的文件? 我用你的附件执行我改动的代码, 得到的就是我给你的截图

france723

wanl01 发表于 2017-5-5 20:41
是呀，为什么我不可以的呢，~
分表
总表

我知道了, 执行代码前, 你把之前错误的那一张"可配"表删除.他会新建一张"可配"表

wanl01

france723 发表于 2017-5-5 20:50
我知道了, 执行代码前, 你把之前错误的那一张"可配"表删除.他会新建一张"可配"表

我是删了，再另外重新新建excel都是不行啊，
执行后你的分表表头有变动位置吗？

france723

wanl01 发表于 2017-5-5 21:01
我是删了，再另外重新新建excel都是不行啊，
执行后你的分表表头有变动位置吗？

分表表头没有变动位置, 错误的那一张"可配"表如果没有删除, 会出现和你一样的问题

wanl01

france723 发表于 2017-5-5 21:06
分表表头没有变动位置, 错误的那一张"可配"表如果没有删除, 会出现和你一样的问题

那为什么我会这样的呢，我已经是新建excel，再执行宏