|
|
楼主 |
发表于 2023-11-23 18:45
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 dgseg 于 2023-11-23 19:02 编辑
麻烦老师给看看。还想加个锁定，生成的新表，锁定后不呢更改
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
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-11-21 20:30
