汇总数据.rar (3.75 MB)

程序代码：

    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

程序代码：

 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 

程序代码：

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