首页
学习
活动
专区
圈层
工具
发布
社区首页 >问答首页 >VBA:打开文件、计算、粘贴值、重复

VBA:打开文件、计算、粘贴值、重复
EN

Stack Overflow用户
提问于 2017-06-13 00:18:39
回答 0查看 352关注 0票数 0

我正在尝试编写一个宏,它将在提供的目录中一个接一个地打开文件,计算所有公式,将值粘贴到特定公式上,保存并退出,对下一个文件重复处理。下面是我所拥有的:

代码语言:javascript
复制
Sub LoopPaloSnapshot()

Dim wb As Workbook
Dim ws As Worksheet
Dim MyPath As String
Dim FldrPicker As FileDialog
Dim FSO As New FileSystemObject
Dim MyFolder As Folder
Dim SubFolder As Folder
Dim MyFile2 As File

Application.ScreenUpdating = True
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    MyPath = .SelectedItems(1) & "\"
End With

Set FSO = CreateObject("scripting.filesystemobject")


'In Case of Cancel
NextCode:

MyPath = MyPath

Set MyFolder = FSO.GetFolder(MyPath)

For Each SubFolder In MyFolder.SubFolders

For Each MyFile2 In SubFolder.Files


If FSO.GetExtensionName(MyFile2.Path) = "xlsx" Then

    Set wb = Workbooks.Open(Filename:=MyFile2, UpdateLinks:=0)

    Set ws = wb.Worksheets("Staffing Model")

       Application.Run ("PALO.CALCSHEET")
       Application.Calculate
       Application.Run ("PALO.CALCSHEET")
       Application.Calculate

    Application.Calculation = xlCalculationManual

        ws.Range("B1").Select
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks _
         :=False, Transpose:=False
        ws.Range("F10:Q10").Value = ws.Range("F10:Q10").Value
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks _
         :=False, Transpose:=False
        ws.Range("F20:Q22").Value = ws.Range("F20:Q22").Value
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks _
         :=False, Transpose:=False
        ws.Range("F42:Q43").Value = ws.Range("F42:Q43").Value
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks _
         :=False, Transpose:=False
        ws.Range("F56:Q56").Value = ws.Range("F56:Q56").Value
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks _
         :=False, Transpose:=False
        ws.Range("F61:Q61").Value = ws.Range("F61:Q61").Value
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks _
         :=False, Transpose:=False
        ws.Range("F66:Q66").Value = ws.Range("F66:Q66").Value
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 
SkipBlanks _
         :=False, Transpose:=False

'Break Links
    If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
    For Each link In wb.LinkSources(xlExcelLinks)
    wb.BreakLink link, xlLinkTypeExcelLinks
    Next link
    End If

Dim xWs As Worksheet
For Each xWs In Application.ActiveWorkbook.Worksheets
    If xWs.Name <> "Staffing Model" Then
        xWs.Delete
    End If
Next

    'Save and Close Workbook
    wb.Close SaveChanges:=True

'Loop

End If

Next
Next

MsgBox "Task Complete!"

ResetSettings:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

运行此程序后,我打开新保存的文件,其中有#Value错误,而不是im试图计算和粘贴值的公式。我试着逐行遍历宏,它似乎在很大程度上工作正常,但由于某些原因,公式不能计算。如果我在运行宏之前手动打开文件,所有的计算都会完美地进行,所以我想知道是不是有什么东西导致这些公式在宏运行时不能计算。任何帮助都将不胜感激。

编辑:复制和粘贴值的公式是HLOOKUP从工作簿中的其他选项卡中提取的,PALO公式直接从JEDOX服务器中提取数据。我已经手动地运行了im尝试自动化而没有错误的过程。

EN

回答

页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接:

https://stackoverflow.com/questions/44504185

复制
相关文章

相似问题

领券
问题归档专栏文章快讯文章归档关键词归档开发者手册归档开发者手册 Section 归档