ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 403|回复: 19

请教老师们一个表格拆分填入统计模版自动识别名称

[复制链接]

TA的精华主题

TA的得分主题

发表于 2023-11-21 20:30 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
借用论坛老师的代码改了一下拆分统计报表填入模版时,自动识别的组织名称不是对应的企业名,而是下一行表格的企业名称,请老师们给修改一下,在此感谢!
1.png
2.png

TA的精华主题

TA的得分主题

发表于 2023-11-22 08:09 | 显示全部楼层
建议上传附件

TA的精华主题

TA的得分主题

 楼主| 发表于 2023-11-22 09:21 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 dgseg 于 2023-11-24 08:40 编辑

上传了,麻烦给看看,表格标题自动识别组织名称,中间有两个公司的会提示覆盖,没有重复的车牌

TA的精华主题

TA的得分主题

 楼主| 发表于 2023-11-23 17:23 | 显示全部楼层
大师给指点一下生成的新表后面多出一行空白行

TA的精华主题

TA的得分主题

发表于 2023-11-23 18:26 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
修改成这样就行。但是你不觉得卡吗?
image.jpg

TA的精华主题

TA的得分主题

 楼主| 发表于 2023-11-23 18:36 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
有点卡,还有生成新的表格,最后多出一个空白行,怎么去掉,还请老师指正
5.png

TA的精华主题

TA的得分主题

发表于 2023-11-23 18:39 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2023-11-23 18:40 | 显示全部楼层
shiruiqiang 发表于 2023-11-23 18:26
修改成这样就行。但是你不觉得卡吗?

今天又改了一下,名称可以下面多出的一行不知道怎么删除

TA的精华主题

TA的得分主题

 楼主| 发表于 2023-11-23 18:42 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
shiruiqiang 发表于 2023-11-23 18:26
修改成这样就行。但是你不觉得卡吗?

现在名称改成这个可以读取到了
shtOut.[a1] = "'" & sName & "摄像头巡检"

TA的精华主题

TA的得分主题

 楼主| 发表于 2023-11-23 18:45 | 显示全部楼层
本帖最后由 dgseg 于 2023-11-23 19:02 编辑
ykcbf1100 发表于 2023-11-23 18:39
最后一行Clear一下就行。

麻烦老师给看看。还想加个锁定,生成的新表,锁定后不呢更改
Sub AllData()
'开始批处理

    Dim iRow As Integer
    Dim iRowBegin As Integer
    Dim iRowEnd As Integer
    Dim iRow_all As Integer
    Dim strUser As String
    Dim stemp As String
    Dim strPath As String
   
   
    Dim shtList As Object
    Dim shtOut As Object
    Set shtList = Sheets("列表")
    Set shtOut = Sheets("模板")
   
    '选择保存路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "C:\Users\Administrator\桌面"
        If .Show = False Then
           Exit Sub
        End If
        
        strPath = .SelectedItems(1)
    End With
   
    '列表最大行号
    iRow_all = shtList.Range("A65535").End(xlUp).Row
   
    iRowBegin = 3    '开始行号
    strUser = Trim(shtList.Cells(2, 1))
   
    '从列表开始行号3开始处理
    For iRow = 3 To iRow_all Step 1
        stemp = Trim(shtList.Cells(iRow, 2))
        
        If strUser <> stemp Or iRow = iRow_all Then
            iRowEnd = iRow - 1
            '处理最后一行
            If iRow = iRow_all Then
                iRowEnd = iRow_all
            End If
            '处理同一个组织名称的数据,保存到一个文件,请先对列表数据进行排序,按照组织名称进行排序
            Call PathData(iRowBegin, iRowEnd, strUser, strPath)
            
            iRowBegin = iRow
            strUser = shtList.Cells(iRow, 2)
        End If
    Next

End Sub

Function PathData(iBegin As Integer, iEnd As Integer, sName As String, sPath As String)
'子程序 根据列表起止行号将列表数据写入到模板中,并另外文件
'iBegin 开始行号, iEnd 结束行号, sName 文件名, sPath 另存文件路径

    If iBegin = 1 Or iEnd = 0 Or iBegin > iEnd Then
      Exit Function
    End If
   
    Dim shtList As Object
    Dim shtOut As Object
    Set shtList = Sheets("列表")
    Set shtOut = Sheets("模板")
   
    shtOut.Rows("5:65535").Delete Shift:=xlUp '删除所有数据行
   
    Dim iRowList As Integer
    Dim iRowOut As Integer
    Dim iCount As Integer
   
    iCount = 1
    iRowOut = 5 '模板用于填写数据的位置行号
    For iRowList = iBegin To iEnd Step 1
        shtOut.Range("A" & iRowOut).Value = iCount
        shtOut.Range("B" & iRowOut).Value = "'" & shtList.Range("B" & iRowList).Value
        shtOut.Range("C" & iRowOut).Value = "'" & shtList.Range("C" & iRowList).Value
        shtOut.Range("D" & iRowOut).Value = shtList.Range("D" & iRowList).Value
        shtOut.Range("E" & iRowOut).Value = shtList.Range("E" & iRowList).Value
        shtOut.Range("F" & iRowOut).Value = shtList.Range("F" & iRowList).Value
        shtOut.Range("G" & iRowOut).Value = shtList.Range("G" & iRowList).Value
        shtOut.Range("H" & iRowOut).Value = "'" & shtList.Range("H" & iRowList).Value
        shtOut.Range("I" & iRowOut).Value = "'" & shtList.Range("I" & iRowList).Value
        iCount = iCount + 1
        iRowOut = iRowOut + 1
    Next
   
   '边框线
    shtOut.Range("A4:I" & iRowOut).Borders(xlEdgeLeft).LineStyle = xlContinuous
    shtOut.Range("A4:I" & iRowOut).Borders(xlEdgeTop).LineStyle = xlContinuous
    shtOut.Range("A4:I" & iRowOut).Borders(xlEdgeBottom).LineStyle = xlContinuous
    shtOut.Range("A4:I" & iRowOut).Borders(xlEdgeRight).LineStyle = xlContinuous
    shtOut.Range("A4:I" & iRowOut).Borders(xlInsideVertical).LineStyle = xlContinuous
    shtOut.Range("A4:I" & iRowOut).Borders(xlInsideHorizontal).LineStyle = xlContinuous
   
    '字体
    shtOut.Range("A4:I" & iRowOut).Font.Name = "宋体"
    shtOut.Range("A4:I" & iRowOut).Font.Size = 10
    shtOut.Range("A4:I" & iRowOut).HorizontalAlignment = xlCenter
    shtOut.Range("A" & iRowOut + 3).Font.Name = "宋体"
    shtOut.Range("A" & iRowOut + 3).Font.Size = 14
    shtOut.Range("A" & iRowOut + 3).RowHeight = 48
    shtOut.Range("A" & iRowOut + 4).RowHeight = 35
   
    '底部签名栏
    shtOut.Range("A" & iRowOut + 3).Value = "监管建议:                                                                                              "
    shtOut.Range("A" & iRowOut + 4).Value = "                                                                                              企业监管人签收:                   "
   
   
    shtOut.[a1] = "'" & sName & "摄像头巡检"
    shtOut.[a2] = "巡检时间:"
    shtOut.[a3] = "第三方机构: 设备有限公司"
   
   '另存文件
    Dim sFileName As String
    Dim wbOut As Object
   
    sFileName = sPath & "\" & sName & ".xlsx"
    shtOut.Copy
    Set wbOut = ActiveWorkbook
    wbOut.ActiveSheet.Name = sName
    wbOut.SaveAs Filename:=sFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, ConflictResolution:=xlLocalSessionChanges
     
     '关闭
    wbOut.Close False
End Function
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-6-23 07:36 , Processed in 0.033209 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表