合并多张表时数据重叠 [英] Data overlaps when merging multiple sheets
本文介绍了合并多张表时数据重叠的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
Sub Combine（）
'此宏将复制所有行第一张表
'（包括标题）
'，下一张表将只复制数据
'（从第2行开始）
Dim i As Integer
Dim j As Long
Dim SheetCnt As Integer
Dim lstRow1 As Long
Dim lstRow2 As Long
Dim lstCol As Integer
Dim ws1 As Worksheet
应用程序
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
结束
错误恢复下一步
'删除文档上的目标表（如果存在）
表（目标）。删除
'计算工作簿上的工作表数
SheetCnt = Worksheets.Count
'添加目标表
Sheets.Add after：= Worksheets（SheetCnt）
ActiveSheet.Name =Target
设置ws1 = Sheets（Target）
lstRow2 = 1
'定义开始复制的行
'（firs t表格将是行1以包括标题）
j = 1
'组合表
对于i = 1 To SheetCnt
工作表（i）。选择
'检查最后一列是数据
lstCol = ActiveSheet.Cells（1，ActiveSheet.Columns.Count）.End（xlToLeft）.Column
'check数据的最后一行是
lstRow1 = ActiveSheet.Cells（ActiveSheet.Rows.Count，A）。End（xlUp）.Row
'定义要复制的范围
范围（A2：G2& j，Cells（lstRow1，lstCol））。选择
'复制数据
Selection.Copy
ws1.Range（A2：G2& lstRow2）.PasteSpecial
Application.CutCopyMode = False
Selection.Offset（1，0）.Resize（Selection.Rows.Count - 1）。选择
'定义目标上的最后一行表
lstRow2 = ws1.Cells（65535，A）。End（xlUp）.Row + 1
'定义行开始复制的行
'（第二张页面将是第2行只获取数据）
j = 3
下一个
应用程序
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
结束
表单（目标）。选择
Cells.EntireColumn.AutoFit
范围（A1） 。选择
End Sub
使用此代码，我的所有表格的数据正在重叠。我想要的数据是一个低于另一个。
解决方案
它是重叠的，因为你不会增加目标的粘贴区域
要解决问题，相应地偏移粘贴区域：
- Sheet 1 ：复制10行粘贴 - >增量粘贴开始&结束区域 10
- 表格2：复制15行粘贴 - >增量粘贴开始&结束区域由 25 ：10 + 15等等...
您也可以替换为：
Sheets.Add after：= Worksheets（SheetCnt）'添加目标表
ActiveSheet.Name =Target
设置ws1 =表（目标）
与此：
设置ws1 = Sheets.Add（after：= Worksheets（SheetCnt））'添加目标表
ws1.Name =Target
如果您消除所有选择语句并明确引用每个对象，它将允许您减少代码，和不需要的复杂性
这是我的版本：
Option Explicit
公共子组合（）
Const HEADR As Byte = 1
Dim i As Long，rngCurrent作为范围
Dim ws As Worksheet，wsTarget As Worksheet
Dim lCol As Long，lCel As Range
Dim lRow As Long，toLRow As Long
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
结束
对于每个ws在工作表中删除目标表如果存在
使用ws
如果.Name =Target然后
.Delete
退出
结束If
结束
下一个
设置wsTarget = Worksheets.Add（After：= Worksheets（Worksheets.Count））
wsTarget.Name =Target
设置lCel = GetMaxCell（Worksheets（1）.UsedRange）
如果lCel.Row> 1然后
与工作表（1）
'预计：所有工作表将具有相同数量的列
lCol = lCel.Column
lRow = HEADR
toLRow = HEADR
.Range（.Cells（HEADR，1），.Cells（HEADR，lCol））。复制
使用wsTarget
.Range（.Cells（HEADR，1） .Cells（HEADR，lCol））。PasteSpecial xlPasteAll
End With
End With
For i = 1 To Worksheets.Count'concatenate data -------- -------------------
设置lCel = GetMaxCell（Worksheets（i）.UsedRange）
如果lCel.Row> 1然后
与工作表（i）
如果.Name<> Target然后'目标
toLRow = toLRow + lRow'目标的最后一行
lRow = lCel.Row'当前
上的最后一行设置rngCurrent = .Range（.Cells（HEADR + 1，1），_
.Cells（lRow，lCol））
lRow = lRow - HEADR
带有wsTarget
.Range（.Cells（toLRow，1），_
.Cells（toLRow +（lRow - HEADR），lCol））= _
rngCurrent.Value
结束
结束如果
结束
结束如果
Next'------------------------------------------- -------------------------
带有wsTarget
.Columns.AutoFit
.Range（A1） 。选择
结束
应用程序
.CutCopyMode = False
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End with
End If
End Sub
公共函数GetMaxCell（可选ByRef rng As Range = Nothing）As Range
'返回包含值的最后一个单元格，如果工作表为空，则返回A1
Const NONEMPTY As String =*
Dim lRow As Range，lCol As Range
如果rng不是，然后设置rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
如果WorksheetFunction.CountA（rng） = 0然后
设置GetMaxCell = rng.Parent.Cells（1，1）
Else
与rng
设置lRow = .Cells.Find（什么：= NONEMPTY，LookIn： = xlFormulas，_
之后：=。单元格（1，1），_
SearchDirection：= xlPrevious，_
SearchOrder：= xlByRows）
如果不是lRow是没有
设置lCol = .Cells.Find（什么：= NONEMPTY，LookIn：= xlFormulas，_
之后：=。 （1，1），_
SearchDirection：= xlPrevious，_
SearchOrder：= xlByColumns）
设置GetMaxCell = .Parent.Cells（lRow.Row，lCol.Column）
End If
End With
End If
End Function
'----------------- -------------------------------------------------- -------------------
粘贴区域通过递增lRow和toLRow来完成
编辑：
如果您使用此代码，所有数据单元的传输单元格格式替换此部分：
'将数据复制到目标表
使用wsTarg et
.Range（.Cells（toLRow，1），.Cells（toLRow +（lRow - HEADR），lCol））= _
rngCurrent.Value
结束
与此：
'将数据复制到目标表
rngCurrent.Copy
带有wsTarget
带.Range（.Cells（toLRow，1））.Cells（toLRow +（lRow - HEADR），lCol））
.PasteSpecial xlPasteAll
结束
结束
但它
编辑：显示如何处理特殊情况
上述解决方案更通用，并动态检测包含数据的最后一列和行
要处理的列数（和行数）可以手动更新。例如，如果您的表格包含43列数据，并且要排除最后2列，请对脚本进行以下更改：
行
设置lCel = GetMaxCell（Worksheets（1）.UsedRange）
更改为
设置lCel = Worksheets（1）.UsedRange（D41）
I have an Excel workbook which contains n sheets. I want to merge the data from each sheet to one single sheet. The header and data from the first sheet should be on top, the data from second sheet should be below it and so on. All the sheets have the same columns and headers structure. So, the header should appear only once i.e take header and data from first sheet and only data from remaining sheets. I have the following code:
Sub Combine()
'This macro will copy all rows from the first sheet
'(including headers)
'and on the next sheets will copy only the data
'(starting on row 2)
Dim i As Integer
Dim j As Long
Dim SheetCnt As Integer
Dim lstRow1 As Long
Dim lstRow2 As Long
Dim lstCol As Integer
Dim ws1 As Worksheet
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
On Error Resume Next
'Delete the Target Sheet on the document (in case it exists)
Sheets("Target").Delete
'Count the number of sheets on the Workbook
SheetCnt = Worksheets.Count
'Add the Target Sheet
Sheets.Add after:=Worksheets(SheetCnt)
ActiveSheet.Name = "Target"
Set ws1 = Sheets("Target")
lstRow2 = 1
'Define the row where to start copying
'(first sheet will be row 1 to include headers)
j = 1
'Combine the sheets
For i = 1 To SheetCnt
Worksheets(i).Select
'check what is the last column with data
lstCol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
'check what is the last row with data
lstRow1 = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
'Define the range to copy
Range("A2:G2" & j, Cells(lstRow1, lstCol)).Select
'Copy the data
Selection.Copy
ws1.Range("A2:G2" & lstRow2).PasteSpecial
Application.CutCopyMode = False
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
'Define the new last row on the Target sheet
lstRow2 = ws1.Cells(65535, "A").End(xlUp).Row + 1
'Define the row where to start copying
'(2nd sheet onwards will be row 2 to only get data)
j = 3
Next
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
Sheets("Target").Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub
With this code, my data from all sheets is getting overlapped. I want the data to be one below the other.
解决方案
It's overlapping because you don't increment the paste area on the Target sheet
To fix the problem offset the paste area correspondingly:
- Sheet 1: copy 10 rows-paste -> increment paste start & end area by 10
- Sheet 2: copy 15 rows-paste -> increment paste start & end area by 25: 10 + 15 and so on...
You can also replace this:
Sheets.Add after:=Worksheets(SheetCnt) 'Add the Target Sheet
ActiveSheet.Name = "Target"
Set ws1 = Sheets("Target")
with this:
Set ws1 = Sheets.Add(after:=Worksheets(SheetCnt)) 'Add the Target Sheet
ws1.Name = "Target"
If you eliminate all "Select" statements and refer to each object explicitly it will allow you to reduce code, and un-needed complexity
Here is my version:
Option Explicit
Public Sub Combine()
Const HEADR As Byte = 1
Dim i As Long, rngCurrent As Range
Dim ws As Worksheet, wsTarget As Worksheet
Dim lCol As Long, lCel As Range
Dim lRow As Long, toLRow As Long
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
For Each ws In Worksheets 'Delete Target Sheet if it exists
With ws
If .Name = "Target" Then
.Delete
Exit For
End If
End With
Next
Set wsTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wsTarget.Name = "Target"
Set lCel = GetMaxCell(Worksheets(1).UsedRange)
If lCel.Row > 1 Then
With Worksheets(1)
'Expected: all sheets will have the same number of columns
lCol = lCel.Column
lRow = HEADR
toLRow = HEADR
.Range(.Cells(HEADR, 1), .Cells(HEADR, lCol)).Copy
With wsTarget
.Range(.Cells(HEADR, 1), .Cells(HEADR, lCol)).PasteSpecial xlPasteAll
End With
End With
For i = 1 To Worksheets.Count 'concatenate data ---------------------------
Set lCel = GetMaxCell(Worksheets(i).UsedRange)
If lCel.Row > 1 Then
With Worksheets(i)
If .Name <> "Target" Then 'exclude the Target
toLRow = toLRow + lRow 'last row on Target
lRow = lCel.Row 'last row on current
Set rngCurrent = .Range(.Cells(HEADR + 1, 1), _
.Cells(lRow, lCol))
lRow = lRow - HEADR
With wsTarget
.Range(.Cells(toLRow, 1), _
.Cells(toLRow + (lRow - HEADR), lCol)) = _
rngCurrent.Value
End With
End If
End With
End If
Next '--------------------------------------------------------------------
With wsTarget
.Columns.AutoFit
.Range("A1").Select
End With
With Application
.CutCopyMode = False
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
End If
End Sub
Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
'Returns the last cell containing a value, or A1 if Worksheet is empty
Const NONEMPTY As String = "*"
Dim lRow As Range, lCol As Range
If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
If WorksheetFunction.CountA(rng) = 0 Then
Set GetMaxCell = rng.Parent.Cells(1, 1)
Else
With rng
Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows)
If Not lRow Is Nothing Then
Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns)
Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
End If
End With
End If
End Function
'--------------------------------------------------------------------------------------
Offsetting the paste area is done by incrementing lRow and toLRow
Edit:
If you use this code and you want to transfer cell formatting for all data cells replace this section:
'copy data to Target sheet
With wsTarget
.Range(.Cells(toLRow, 1), .Cells(toLRow + (lRow - HEADR), lCol)) = _
rngCurrent.Value
End With
with this:
'copy data to Target sheet
rngCurrent.Copy
With wsTarget
With .Range(.Cells(toLRow, 1), .Cells(toLRow + (lRow - HEADR), lCol))
.PasteSpecial xlPasteAll
End With
End With
but it will become slower if you're processing a lot of sheets
EDIT: to show how to handle special cases
The above solution is more generic and dynamically detects the last column and row containing data
The number of columns (and rows) to be processed can be manually updated. For example, if your sheets contain 43 columns with data, and you want to exclude the last 2 columns, make the following change to the script:
Line
Set lCel = GetMaxCell(Worksheets(1).UsedRange)
changes to
Set lCel = Worksheets(1).UsedRange("D41")
这篇关于合并多张表时数据重叠的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
