[已解决]如何实现合并多个工作簿的sheet1到同一个新工作簿的sheet1中？

gpgpgp111 · 发表于 2013-3-5 17:30

如何实现合并多个工作簿的sheet1到同一个新工作簿的sheet1中？我试了好几个vba代码，文件多了就出现数据丢失情况，但工作簿数据仅几十个！

请各位大师帮帮忙好吗？

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-3-5 18:15

合并工作簿.rar (17.11 KB, 下载次数: 848)

hwc2ycy · 发表于 2013-3-5 17:32

关键是里面的数据格式是否一样了。如果存放数据的位置都不一样，这样的合并就无意义了。

gpgpgp111 · 发表于 2013-3-5 17:37

数据格式是一样,存放数据的位置大致一样，就是上下差几行

hwc2ycy · 发表于 2013-3-5 18:15

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

合并工作簿.rar (17.11 KB, 下载次数: 848)

ynwangrong · 发表于 2013-3-7 14:54

有专门的工具，那当然好了。

1552174482 · 发表于 2014-1-11 19:55

hwc2ycy 发表于 2013-3-5 18:15
放到要合并的工作簿目录中，点按钮开始。

这个太牛了，能不能从指定行开始合并？

hwc2ycy · 发表于 2014-1-11 20:28

1552174482 发表于 2014-1-11 19:55
这个太牛了，能不能从指定行开始合并？

需要把意图说明白，才好修改。

1552174482 · 发表于 2014-1-11 20:41

本帖最后由 1552174482 于 2014-1-11 20:47 编辑

hwc2ycy 发表于 2014-1-11 20:28
需要把意图说明白，才好修改。

比如我要从所有sheet1的第4行开始合并，因为前三行是公司抬头什么的，我不需要。
需要在您的宏里改哪些值？
下面是您的宏：
Sub 工作表()
Dim sFile$
Dim sPath
Dim wbSource As Workbook
Dim strErrMsg As String
Dim shtDst As Worksheet
Dim arr
Dim lRow As Long

Application.ScreenUpdating = False

Set shtDst = Worksheets.Add(after:=Worksheets(Worksheets.Count))
On Error Resume Next
sPath = ThisWorkbook.Path & Application.PathSeparator

sFile = Dir(sPath & "*.xl*", vbNormal + vbDirectory)

Do While Len(sFile) > 0
      If Not sFile Like ThisWorkbook.Name Then
         Set wbSource = GetObject(sPath & sFile)
         If Not wbSource Is Nothing Then
            With wbSource.Worksheets("sheet1")
                  arr = .UsedRange.Value
            End With
            wbSource.Close False
            With shtDst
                  lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                  .Cells(lRow, 1).Resize(UBound(arr), UBound(arr)) = arr
            End With
            Set wbSource = Nothing
         Else
            strErrMsg = strErrMsg & sFile & "读取错误"
            Set wbSource = Nothing
         End If
      End If
      sFile = Dir
Loop

MsgBox "数据已经汇总在" & ActiveWorkbook.Name & " 的 " & ActiveSheet.Name & vbCr & "按确定后开始保存", vbInformation + vbOKOnly
ActiveWorkbook.Save
Application.ScreenUpdating = True
If Len(strErrMsg) > 0 Then
      MsgBox strErrMsg
Else
      MsgBox "合并完成"
End If
End Sub

hwc2ycy · 发表于 2014-1-11 21:18

1552174482 发表于 2014-1-11 20:41
比如我要从所有sheet1的第4行开始合并，因为前三行是公司抬头什么的，我不需要。
需要在您的宏里改哪些值 ...

Sub 工作表()
Dim sFile$
Dim sPath
Dim wbSource As Workbook
Dim strErrMsg As String
Dim shtDst As Worksheet
Dim arr, arrHeader
Dim lRow As Long
Dim HasHeader As Boolean
Do While Len(sFile) > 0
If Not sFile Like ThisWorkbook.Name Then
Set wbSource = GetObject(sPath & sFile)
With wbSource.Worksheets("sheet1")
With .UsedRange
arrHeader = .Rows("1:3").Value
arr = .Rows("4:" & .Rows.Count).Value
End With
End With
wbSource.Close False
With shtDst
If Not HasHeader Then
.Range("a1").Resize(UBound(arrHeader), UBound(arrHeader, 2)).Value = arrHeader
HasHeader = True
End If
lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(lRow, 1).Resize(UBound(arr), UBound(arr)) = arr
End With
Set wbSource = Nothing
Else
strErrMsg = strErrMsg & sFile & "读取错误"
Set wbSource = Nothing
End If
sFile = Dir
Loop
MsgBox "数据已经汇总在" & ActiveWorkbook.Name & " 的 " & ActiveSheet.Name & vbCr & "按确定后开始保存", vbInformation + vbOKOnly
ActiveWorkbook.Save
Application.ScreenUpdating = True
If Len(strErrMsg) > 0 Then
MsgBox strErrMsg
Else
MsgBox "合并完成"
End If
End Sub

复制代码

你自己测下吧，我这没法测。

1552174482 · 发表于 2014-1-11 21:49

hwc2ycy 发表于 2014-1-11 21:18
你自己测下吧，我这没法测。

貌似不行，连合并都不行了，
上传了附件了，如果有空麻烦帮下忙，好不容易找到这个帖子的。
顶端标题行重复或没有也不要紧的，如果能只有一个就最好了。
其实现在的那个宏对我已经很有用了。

		自动登录	找回密码
密码			注册

[已解决]如何实现合并多个工作簿的sheet1到同一个新工作簿的sheet1中？

相关帖子