求批量提取工作表另存

liulang0808

1. Sub 按钮20_Click()
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     pth = ThisWorkbook.Path & "\资管"
   
6.     arr = Array("工作量", "经纬度")
   
7.     If Not fso.folderexists(pth) Then
   
8.         MkDir pth
   
9.     End If
   
10.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
    
11.         If InStr(f.Name, "批量处理宏代码") = 0 Then
    
12.             With Workbooks.Open(f)
    
13.                 .Unprotect "92101"
    
14.                 .Sheets(arr).Copy
    
15.                 With ActiveWorkbook
    
16.                     .Sheets("工作量").Unprotect
    
17.                     .Sheets("工作量").UsedRange.Value = .Sheets("工作量").UsedRange.Value
    
18.                     .SaveAs Filename:=pth & .Sheets("工作量").[a3] & ".xls", FileFormat:=xlExcel8
    
19.                     .Close False
    
20.                 End With
    
21.                 .Close False
    
22.             End With
    
23.         End If
    
24.     Next f
    
25. 
    
26.     Application.DisplayAlerts = True
    
27.     Application.ScreenUpdating = True
    
28. End Sub
    

复制代码

liulang0808

附件内容供参考，楼主附件各种保护啊

宋家老六

xiangbaoan 发表于 2018-9-17 16:21
……审核，附件……

您好，工作量表格的数据需要清除0这个数据 这个怎么处理？

xiangbaoan

宋家老六 发表于 2018-9-17 16:31
您好，工作量表格的数据需要清除0这个数据 这个怎么处理？

那就加一句
.usedrange.replace  0,  "" ,  xlwhole

宋家老六

版主 我还需要对工作量表的数据清零处理 以下是代码
   
Sheets("工作量").Select
    Rows("3:3").Select
    Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

这代码应该放在哪个位置？

宋家老六

楼上两位老师，已搞定该代码。

谢谢版主及xiangbaoan完成了主代码。

宋家老六

Sub 按钮20_Click()
    Set fso = CreateObject("scripting.filesystemobject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    pth = ThisWorkbook.Path & "\资管\"
    arr = Array("工作量", "经纬度")
    If Not fso.folderexists(pth) Then
        MkDir pth
    End If
    For Each f In fso.getfolder(ThisWorkbook.Path).Files
        If InStr(f.Name, "资管---------批量提取") = 0 Then
            With Workbooks.Open(f)
                .Unprotect "92101"
                .Sheets(arr).Copy
                With ActiveWorkbook
                    .Sheets("工作量").Unprotect
                    .Sheets("工作量").UsedRange.Value = .Sheets("工作量").UsedRange.Value
   
   
   
    '自用代码开始
   
    '对经纬度表格的数据尾数进行处理 不能有0结束
   
    Sheets("经纬度").Select
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "=ROUND(RC[-4],5)+(RANDBETWEEN(1,9)/1000000)"
    Selection.AutoFill Destination:=Range("G2:H2"), Type:=xlFillDefault
    Range("G2:H2").Select
    Selection.AutoFill Destination:=Range("G2:H1000"), Type:=xlFillDefault
    Range("G2:H1000").Select
    Selection.Copy
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("F:J").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("E2").Select
   
    '删除表格内空值行（清理一下母表带来的未可知的一些数据）
    Columns("A:B").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
   
    '从第二行开始清理表格边框
    Rows("2:1040").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
   
   
    '工作量表格清零
    .Sheets("工作量").Select
    Rows("3:3").Select
    Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
   '自用代码结束
        
                    .SaveAs Filename:=pth & .Sheets("工作量").[a3] & ".xls", FileFormat:=xlExcel8
                    .Close False
                End With
                .Close False
            End With
        End If
    Next f

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub




版主，我在您的代码基础上进行了一系列的数据加工  主要就是按照系统要求对数据进行格式，数值的清理及转换。可以完美运行 ， 但是有个问题 ， 整体代码执行起来效率不高 不知道能不能有所优化？

liulang0808

1. Sub 按钮20_Click()
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     pth = ThisWorkbook.Path & "\资管"
   
6.     arr = Array("工作量", "经纬度")
   
7.     If Not fso.folderexists(pth) Then
   
8.         MkDir pth
   
9.     End If
   
10.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
    
11.         If InStr(f.Name, "批量处理宏代码") = 0 Then
    
12.             With Workbooks.Open(f)
    
13.                 .Unprotect "92101"
    
14.                 .Sheets(arr).Copy
    
15.                 With ActiveWorkbook
    
16.                     .Sheets("工作量").Unprotect
    
17.                     .Sheets("工作量").UsedRange.Value = .Sheets("工作量").UsedRange.Value
    
18.                     .Sheets("工作量").UsedRange.Replace What:="0", Replacement:="", LookAt:=xlWhole
    
19. 
    
20.                     .SaveAs Filename:=pth & .Sheets("工作量").[a3] & ".xls", FileFormat:=xlExcel8
    
21.                     .Close False
    
22.                 End With
    
23.                 .Close False
    
24.             End With
    
25.         End If
    
26.     Next f
    
27. 
    
28.     Application.DisplayAlerts = True
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。