注册 登录
编程论坛 → VFP论坛

excel工作表合并问题，求解决

自强不西 发布于 2021-12-08 19:58， 3718 次点击
数据处理，一般需要从企业系统中导出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
17 回复
#2
sdta2021-12-08 20:05
用数据说话
#3
自强不西2021-12-08 20:35
只有本站会员才能查看附件，请 登录
#4
自强不西2021-12-08 20:38
把上述文件解压至一个文件夹中，然后运行上面的宏，其中sheet1第60000条图号为C13228、sheet2第60000条图号为C28228、sheet3第60000条图号为C43228的记录在合并后的sheet表中查不到。求版主指教！
#5
sdta2021-12-08 22:56
Set cell = Cells(ActiveSheet.UsedRange.Rows.Count, 1)
改为
Set cell = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1)
试试
#6
吹水佬2021-12-08 23:06
提供的一个文件简单测试一下
程序代码：

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编辑过]
#7
吹水佬2021-12-09 10:50
UsedRange.Rows.Count、UsedRange.Columns.Count 对于首尾有“空行”或“空列”时获取的行数或列数不准确
#8
gs25367856782021-12-10 09:32
关键是你的数据记录条数太多了，VBA也是难于招架了。
#9
吹水佬2021-12-10 15:12
以下是引用gs2536785678在2021-12-10 09:32:15的发言：

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

EXCEL2007以上版本应该没问题
#10
吹水佬2021-12-11 15:47
感觉用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
#11
自强不西2022-01-09 16:04
以下是引用吹水佬在2021-12-11 15:47:12的发言：

感觉用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

感谢版主！这段程序对于一个工作簿中多个工作表的合并确认非常快。如果是多个相同格式的工作簿中的多个工作表的合并，麻烦版主看看有没有好的处理办法。
#12
自强不西2022-01-09 16:06
具体的数据如下，麻烦版主给看下。
只有本站会员才能查看附件，请 登录
#13
吹水佬2022-01-10 00:08
回复 12楼 自强不西
只有本站会员才能查看附件，请 登录

程序代码：
    Dim sh As Worksheet
    Set sh = Sheets(1)
    sh.UsedRange.ClearContents

    Dim mPath
    mPath = ThisWorkbook.Path & "\"
   
    Dim fs As Object, wb As Workbook
    Dim f_name, e_name, nRow, nRows, nRowCount, nColCount
    nRows = 1
    Set fs = CreateObject("Scripting.FileSystemObject")
    For Each file In fs.GetFolder(mPath).Files
        f_name = Split(file.Name, ".")(0)
        e_name = Right(file.Name, Len(file.Name) - Len(f_name))
        If e_name = ".xlsx" Then
            Set wb = Workbooks.Open(file.Path)
            For Each sht In wb.Sheets
                nRowCount = sht.UsedRange.Rows.Count
                nColCount = sht.UsedRange.Columns.Count
                nRow = 1
                If nRows <> 1 And sht.Name = wb.Sheets(1).Name Then
                    nRow = 2
                    nRowCount = nRowCount - 1
                End If
                sht.Cells(nRow, 1).Resize(nRowCount, nColCount).Copy sh.Cells(nRows, 1)
                nRows = nRows + nRowCount
            Next
            wb.Close
        End If
    Next
#14
wengjl2022-01-10 08:07
程序代码：
PUBLIC mypath
  cCurrentProcedure = SYS(16,1)
  nPathStart = AT(":",cCurrentProcedure)- 1
  nLenOfPath = RAT("\", cCurrentProcedure) - (nPathStart)
  mypath=SUBSTR(cCurrentProcedure, nPathStart, nLenofPath)
  SET DEFAULT TO (mypath)
*-----------------------------------------------------
M_File=getfile('xlsx')  
IF EMPTY(M_File)
  RETURN
ENDIF
SELECT 0
USE jlml_zdlh alia zdlh   &&& jlml_zdlh.dbf 是一张EXCEL表字段名与DBF表字段名相对应的表
REPLACE szlh with 0 all
SELECT 0
USE jlml_sjk alia bmk
ZAP
myexcel=createobject('excel.application')  
IF !VARTYPE(myexcel)$"Oo"      &&& 如果用户的电脑上未装EXCEL软件，则结束运行。
    MESSAGEBOX("建立EXCEL文件失败，请检查OFFICE是否正常！",48,"提醒：")
    RETURN
ENDIF
myexcel.visible=.T.                                && 对象可见
bookexcel=myexcel.workbooks.open(M_File)            && 打开指定文件
o_SheetName=myexcel.application.ActiveSheet.Name    && 获取当前激活工作表的名称
o_UsedRange =bookexcel.worksheets(o_SheetName).UsedRange     && 返回工作表中可使用的区域，UsedRange表的属性
o_rows=o_UsedRange.rows.count  
o_cols=o_UsedRange.columns.count  
*--开始检测要导入的数据在EXCEL中各字段所在列的位置
FOR kg=1 to o_cols   
  dyg=bookexcel.worksheets(o_SheetName).cells(3,kg).text   &&& 标题在第3行
  SELECT zdlh
  LOCATE for ALLTRIM(zdlh.ebzdmc)==dyg
  IF FOUND()
    REPLACE zdlh.szlh with kg    &&& 检测到所在列号，进行记录
  ENDIF      
ENDFOR   
   SELECT zdlh
   GO top
   SCAN
     IF szlh=0            &&&　如果有记录的值未改写，会导致后面的语句执行出错，所以这里要结束程序
       myexcel.workbooks.close    && 关闭工作区
       myexcel.quit               && 关闭excel      
       RELEASE myexcel           &&& 释放对象变量，以完全结束EXCEL的进程
       MESSAGEBOX('缺少数据列（“ '+ALLTRIM(zdlh.ebzdmc)+' ”），导致出错，请检查！！！',48,'警告：')     
       RETURN
     ENDIF
   ENDSCAN
   *--检测结束。增加了这个检测，就提高了程序的智能化     
   *--------------------------------------------


 FOR jj=1 TO 31         &&& 根据汇总月份的天数修改   31也可以用变量
   myexcel.sheets(jj).activate           &&& 按日期依次设置为活动工作表
   o_SheetName=myexcel.application.ActiveSheet.Name    && 获取当前激活工作表的名称
   o_UsedRange =bookexcel.worksheets(o_SheetName).UsedRange     && 返回工作表中可使用的区域，UsedRange表的属性
   o_rows=o_UsedRange.rows.count                        && 汇总行
   SELECT bmk
   IF o_rows<=1
     =MESSAGEBOX("待导入数据行数太少，请检查！",0+16,"提示")
   ELSE
     FOR i=4 TO o_rows
       WAIT WINDOW '共有'+ALLTRIM(STR(o_rows-3))+'条记录，正在导入第'+ALLTRIM(STR(i-3))+'条记录...' NOWAIT
       SELECT bmk
       APPEND BLANK
       SELECT zdlh
       GO top
       SCAN
         cfname='bmk.'+ALLTRIM(zdlh.dbzdmc)
         IF zdlh.lx='txt'
           REPLACE (cfname) with myExcel.cells(i,zdlh.szlh).text
         ELSE
           REPLACE (cfname) with myExcel.cells(i,zdlh.szlh).value
         ENDIF
         SELECT zdlh
       ENDSCAN
     ENDFOR
   ENDIF

 ENDFOR

 
myexcel.workbooks.close    && 关闭工作区
myexcel.quit               && 关闭excel
RELEASE myexcel           &&& 释放对象变量，以完全结束EXCEL的进程
SELECT bmk
COPY TO jlmlhz

RETURN


以上代码是我每月的数据转移到DBF的代码。楼主可以借鉴！

我统计销售数据，每天一表，存在同一工作簿上，每天发总经理。
一个月满了，换一个工作簿，这样总经理在一月最后一个工作簿上可以看整月的。
#15
吹水佬2022-01-10 11:07
回复 13楼 吹水佬
修改了一下
程序代码：

Private Sub CommandButton1_Click()
    Dim sh As Worksheet
    Set sh = Sheets(1)
    sh.UsedRange.ClearContents  '清除合并表所有数据

    Dim mPath
    mPath = ThisWorkbook.Path & "\"  '工作簿当前目录
   
    Dim wb As Workbook, fname As String
    Dim nRow, nRows, nRowCount, nColCount
    nRows = 1
    '遍历当前目录所有 xlsx 文件
    fname = Dir(mPath & "*.xlsx")
    Do While Len(fname) <> 0
        Set wb = Workbooks.Open(mPath & fname)  '打开工作簿
        For Each sht In wb.Sheets               '遍历工作簿所有工作表
            nRowCount = sht.UsedRange.Rows.Count
            nColCount = sht.UsedRange.Columns.Count
            nRow = 1
            '如果不是第一个工作簿的第一个工作表，不取第一行（栏目）
            If (nRows <> 1) And (sht Is wb.Sheets(1)) Then
                nRow = 2
                nRowCount = nRowCount - 1
            End If
            sht.Cells(nRow, 1).Resize(nRowCount, nColCount).Copy sh.Cells(nRows, 1)
            nRows = nRows + nRowCount
        Next
        wb.Close
        fname = Dir()
    Loop
End Sub
#16
ls_y0412022-01-10 18:10
回复 14楼 wengjl
您写的字段对应表是如何设置的，想学习一下，这个方法感觉比较好当表的字段有变化时，直接修改对应的字段，就不用再重复写了，只是修改字段对应表就方便了。
#17
wengjl2022-01-11 10:53
只有本站会员才能查看附件，请 登录
#18
自强不西2023-09-07 13:23
谢谢各位楼主！
1
©2025, BC-CN.NET
电脑版