| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 3227 人关注过本帖
标题:excel工作表合并问题,求解决
只看楼主 加入收藏
自强不西
Rank: 2
等 级:论坛游民
帖 子:147
专家分:26
注 册:2019-3-29
结帖率:75%
收藏
已结贴  问题点数:20 回复次数:17 
excel工作表合并问题,求解决
数据处理,一般需要从企业系统中导出20多万,导出的表是一个工作簿,20多万的数据,每个工作表6万条,约4-6个工作表组成一个工作簿。
现需要将几个工作表的数据合并在一个工作表中,以便于数据处理。
我编制了一个VBA宏,运行后,发现每个工作表为6万条记录的第6万条记录没合并到新工作表中,麻烦大佬给指点下。具体程序如下:
Sub 多工作簿合并()
Dim file() As String, filestr As String, n As Integer, m As Integer, pathstr As String, namess As String, activewb As Workbook, cell As Range
With Application.FileDialog(msoFileDialogFolderPicker)
'创建文件对话框的实例
If .Show Then '如果在对话框中单击了“确定”按钮
  pathstr = .SelectedItems(1) '将选定的路径赋予变量
Else
 Exit Sub '否则退出程序
End If
End With
On Error Resume Next
filestr = Dir(pathstr & IIf(Right(pathstr, 1) = "\", "", "\") & "*.xls")
'获取路径下第一个文件名
While Len(filestr) > 0 '只要文件名长度大于零就循环下去
n = n + 1 '累加变量,该变量等于文件个数
ReDim Preserve file(1 To n) '重新指定数组变量的存储空间
file(n) = pathstr & IIf(Right(pathstr, 1) = "\", "", "\") & filestr
'将路径与文件名逐个写入数组
filestr = Dir()
Wend
If n = 0 Then MsgBox "没发现excel文件": Exit Sub  '如果没有文件则退出程序
Set activewb = ActiveWorkbook '将活动工作簿赋予变量
Application.ScreenUpdating = False '关闭屏幕更新,从而提速
Application.Calculation = xlCalculationManual '计算模式调用手动,从而提速
For k = 1 To n '遍历文件夹中所有excel文件
namess = Dir(file(k)) '获取文件夹的名称(忽略路径)
Workbooks.Open FileName:=file(k)   '打开文件
activewb.Activate '返回存放合并数据的工作表
'如果K=1,那么将标题复制到活动工作表A1
For i = 1 To Workbooks(namess).Sheets.Count
'遍历所有工作表,开始合并标题以外的数据
With Workbooks(namess).Sheets(i).UsedRange
'引用待合并工作簿中每个工作表的已用区域
If Not IsEmpty(Workbooks(namess).Sheets(i).UsedRange) Then
'如果非空表
'将合并工作表已用区域的下一行第1个单元格赋予变量(即将合并工作表的A列第一个空单元格赋值给变更cell)
Set cell = Cells(ActiveSheet.UsedRange.Rows.Count, 1)
'将目标数据除标题外全部复制到cell单元格(此次复制,仅仅需要其格式)
cell.Resize(.Rows.Count, .Columns.Count) = .Cells.Value
End If
End With
Next i '合并下一个工作表
Workbooks(namess).Close False '关闭工作簿且不保存
Next k
Application.ScreenUpdating = True '恢复屏幕更新
Application.Calculation = xlCalculationAutomatic '恢复自动计算
End Sub
搜索更多相关主题的帖子: 数据 工作表 工作 文件 合并 
2021-12-08 19:58
sdta
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
来 自:江苏省连云港市
等 级:版主
威 望:335
帖 子:9841
专家分:27213
注 册:2012-2-5
收藏
得分:7 
用数据说话

坚守VFP最后的阵地
2021-12-08 20:05
自强不西
Rank: 2
等 级:论坛游民
帖 子:147
专家分:26
注 册:2019-3-29
收藏
得分:0 
试验数据.rar (851.97 KB)
2021-12-08 20:35
自强不西
Rank: 2
等 级:论坛游民
帖 子:147
专家分:26
注 册:2019-3-29
收藏
得分:0 
把上述文件解压至一个文件夹中,然后运行上面的宏,其中sheet1第60000条图号为C13228、sheet2第60000条图号为C28228、sheet3第60000条图号为C43228的记录在合并后的sheet表中查不到。求版主指教!
2021-12-08 20:38
sdta
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
来 自:江苏省连云港市
等 级:版主
威 望:335
帖 子:9841
专家分:27213
注 册:2012-2-5
收藏
得分:0 
Set cell = Cells(ActiveSheet.UsedRange.Rows.Count, 1)
改为
Set cell = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1)
试试

坚守VFP最后的阵地
2021-12-08 22:56
吹水佬
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:451
帖 子:10607
专家分:43182
注 册:2014-5-20
收藏
得分:7 
提供的一个文件简单测试一下
程序代码:
Private Sub CommandButton1_Click()
    Sheets.Add
    ActiveSheet.Name = "合并表"
    nRows = 1
    For i = 2 To Sheets.Count
        RowCount = Sheets(i).UsedRange.Rows.Count
        ColCount = Sheets(i).UsedRange.Columns.Count
        Value = Sheets(i).Cells(1, 1).Resize(RowCount, ColCount).Value
        ActiveSheet.Range(ActiveSheet.Cells(nRows, 1), ActiveSheet.Cells(nRows + RowCount - 1, ColCount)).Value = Value
        nRows = nRows + RowCount
    Next i
End Sub



[此贴子已经被作者于2021-12-8 23:07编辑过]

2021-12-08 23:06
吹水佬
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:451
帖 子:10607
专家分:43182
注 册:2014-5-20
收藏
得分:0 
UsedRange.Rows.Count、UsedRange.Columns.Count 对于首尾有“空行”或“空列”时获取的行数或列数不准确

2021-12-09 10:50
gs2536785678
Rank: 10Rank: 10Rank: 10
等 级:贵宾
威 望:45
帖 子:610
专家分:1784
注 册:2017-7-16
收藏
得分:7 
关键是你的数据记录条数太多了,VBA也是难于招架了。
2021-12-10 09:32
吹水佬
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:451
帖 子:10607
专家分:43182
注 册:2014-5-20
收藏
得分:0 
以下是引用gs2536785678在2021-12-10 09:32:15的发言:

关键是你的数据记录条数太多了,VBA也是难于招架了。

EXCEL2007以上版本应该没问题
2021-12-10 15:12
吹水佬
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:451
帖 子:10607
专家分:43182
注 册:2014-5-20
收藏
得分:0 
感觉用Copy较快
程序代码:
Private Sub CommandButton1_Click()
    Dim sh As Worksheet, nRows As Long, nRowCount As Long, nColCount As Long
    On Error Resume Next
    If Not Worksheets("合并表") Is Nothing Then
        Application.DisplayAlerts = False
        Worksheets("合并表").Delete
    End If
    Set sh = Worksheets.Add
    sh.Name = "合并表"
    nRows = 1
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "合并表" Then
            nRowCount = Sheets(i).UsedRange.Rows.Count
            nColCount = Sheets(i).UsedRange.Columns.Count
            Sheets(i).Cells(1, 1).Resize(nRowCount, nColCount).Copy sh.Cells(nRows, 1)
            nRows = nRows + nRowCount
        End If
    Next i
End Sub

2021-12-11 15:47
快速回复:excel工作表合并问题,求解决
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.020944 second(s), 9 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved