我在执行宏时遇到问题。
当我逐行执行它时它完美地工作（慢，但完美）。 但是当我使用图形界面中的Button执行它时，它甚至不会打开运行该过程所必需的Excel文件。
下面我将链接我的代码，因为我甚至不知道发生了什么。
我认为它必须是与程序权重相关的一些问题。但我真的不知道。
顺便谢谢你。
Sub Estructura_Activo_Fijo()
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim wbEstructura As Workbook
Dim wsTAG As Worksheet
Dim xWBName As String
Dim xWb As Workbook
Dim est
Dim consfinal
Dim boc
Dim bct
Dim consoc
On Error Resume Next
xWBName = "Estructura.xlsx"
Set wbEstructura = Application.Workbooks(xWBName)
If wbEstructura Is Nothing Then
Workbooks.Open Filename:=ActiveWorkbook.Path & "\Estructura.xlsx"
End If
On Error Resume Next
xWBName = "Consolidado Final.xlsx"
Set xWb = Application.Workbooks(xWBName)
If xWb Is Nothing Then
Workbooks.Open Filename:=ActiveWorkbook.Path & "\BBDD\Biblioteca\BBDD Locales\Consolidado Final.xlsx"
End If
On Error Resume Next
xWBName = "BBDD OC.xlsx"
Set xWb = Application.Workbooks(xWBName)
On Error Resume Next
If xWb Is Nothing Then
Workbooks.Open Filename:=ActiveWorkbook.Path & "\BBDD OC.xlsx"
End If
On Error Resume Next
xWBName = "BBDD CT.xlsx"
Set xWb = Application.Workbooks(xWBName)
If xWb Is Nothing Then
Workbooks.Open Filename:=ActiveWorkbook.Path & "\BBDD CT.xlsx"
End If
On Error Resume Next
xWBName = "Consolidado OC.xlsx"
Set xWb = Application.Workbooks(xWBName)
If wb Is Nothing Then
Workbooks.Open Filename:=ActiveWorkbook.Path & "\Consolidado OC.xlsx"
End If
ActiveWindow.WindowState = xlMinimized
Set wbEstructura = Workbooks("Estructura.xlsx")
Set wsTAG = wbEstructura.Worksheets("TAG")
Workbooks("Estructura.xlsx").Activate
Dim rng1 As Range, FSO
Dim rngTipo As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim error As Long
Dim existente As Long
Dim inicioTiempo As Double
Dim minutosTranscurridos As String
Set rng1 = wsTAG.Range("B2")
Set rngTipo = wsTAG.Range("AE2")
Set FSO = CreateObject("Scripting.FileSystemObject")
ruta = ActiveWorkbook.Path
inicioTiempo = Timer
rutaAño = ruta & "\2017"
rutaFARFI = rutaAño & "\FAR_FI"
rutaFARTA = rutaAño & "\FAR_TA"
rutaFARTN = rutaAño & "\FAR_TN"
rutaGOPMTI = rutaAño & "\GOPM_TI"
If Not FSO.FolderExists(rutaAño) Then
MkDir ruta & "\2017"
i = i + 1
Else
existente = existente + 1
MsgBox "La carpeta \2017 ya existe, el proceso se cerrará.", vbCritical
Exit Sub
End If
If Len(Dir(rutaFARFI, vbDirectory)) = 0 Then
MkDir rutaFARFI
Else
existente = existente + 1
End If
If Len(Dir(rutaFARTA, vbDirectory)) = 0 Then
MkDir rutaFARTA
Else
existente = existente + 1
End If
If Len(Dir(rutaFARTN, vbDirectory)) = 0 Then
MkDir rutaFARTN
Else
existente = existente + 1
End If
If Len(Dir(rutaGOPMTI, vbDirectory)) = 0 Then
MkDir rutaGOPMTI
Else
existente = existente + 1
End If
Do While Not IsEmpty(rng1)
If FSO.FolderExists(rutaAño) Then
v = rng1.Offset(0, 29).Value
Do While IsEmpty(rngTipo)
error = error + 1
Set rngTipo = rngTipo.Offset(1, 0)
Loop
If v = "Padre" Then 'Si 'v' es Padre:
If Not FSO.FolderExists(rutaFARFI & "\" & Left(v, 1) & rng1.Value2) Then
FSO.CreateFolder (rutaFARFI & "\" & Left(v, 1) & rng1.Value2)
i = i + 1
padre = padre + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaFARTA & "\" & Left(v, 1) & rng1.Value2) Then
FSO.CreateFolder (rutaFARTA & "\" & Left(v, 1) & rng1.Value2)
i = i + 1
padre = padre + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaFARTN & "\" & Left(v, 1) & rng1.Value2) Then
FSO.CreateFolder (rutaFARTN & "\" & Left(v, 1) & rng1.Value2)
i = i + 1
padre = padre + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaGOPMTI & "\" & Left(v, 1) & rng1.Value2) Then
FSO.CreateFolder (rutaGOPMTI & "\" & Left(v, 1) & rng1.Value2)
i = i + 1
padre = padre + 1
Else
existente = existente + 1
End If
rutaPadreFARFI = rutaFARFI & "\" & Left(v, 1) & rng1.Value
rutaPadreFARTA = rutaFARTA & "\" & Left(v, 1) & rng1.Value
rutaPadreFARTN = rutaFARTN & "\" & Left(v, 1) & rng1.Value
rutaPadreGOPMTI = rutaGOPMTI & "\" & Left(v, 1) & rng1.Value
ElseIf v = "Componente" Then
If Not FSO.FolderExists(rutaPadreFARFI & "\" & Left(v, 1) & rng1.Value) Then
FSO.CreateFolder (rutaPadreFARFI & "\" & Left(v, 1) & rng1.Value)
i = i + 1
componente = componente + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTA & "\" & Left(v, 1) & rng1.Value) Then
FSO.CreateFolder (rutaPadreFARTA & "\" & Left(v, 1) & rng1.Value)
i = i + 1
componente = componente + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTN & "\" & Left(v, 1) & rng1.Value) Then
FSO.CreateFolder (rutaPadreFARTN & "\" & Left(v, 1) & rng1.Value)
i = i + 1
componente = componente + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreGOPMTI & "\" & Left(v, 1) & rng1.Value) Then
FSO.CreateFolder (rutaPadreGOPMTI & "\" & Left(v, 1) & rng1.Value)
i = i + 1
componente = componente + 1
Else
existente = existente + 1
End If
rutaCompFARFI = rutaPadreFARFI & "\" & Left(v, 1) & rng1.Value
rutaCompFARTA = rutaPadreFARTA & "\" & Left(v, 1) & rng1.Value
rutaCompFARTN = rutaPadreFARTN & "\" & Left(v, 1) & rng1.Value
rutaCompGOPMTI = rutaPadreGOPMTI & "\" & Left(v, 1) & rng1.Value
End If
w = rng1.Offset(0, 1).Value
If v = "Padre" Then
If Not FSO.FolderExists(rutaPadreFARFI & "\" & w) Then
FSO.CreateFolder (rutaPadreFARFI & "\" & w)
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARFI & "\OC") Then
FSO.CreateFolder (rutaPadreFARFI & "\OC")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARFI & "\EP") Then
FSO.CreateFolder (rutaPadreFARFI & "\EP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARFI & "\CAP") Then
FSO.CreateFolder (rutaPadreFARFI & "\CAP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTA & "\" & w) Then
FSO.CreateFolder (rutaPadreFARTA & "\" & w)
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTA & "\OC") Then
FSO.CreateFolder (rutaPadreFARTA & "\OC")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTA & "\EP") Then
FSO.CreateFolder (rutaPadreFARTA & "\EP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTA & "\CAP") Then
FSO.CreateFolder (rutaPadreFARTA & "\CAP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTN & "\" & w) Then
FSO.CreateFolder (rutaPadreFARTN & "\" & w)
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTN & "\OC") Then
FSO.CreateFolder (rutaPadreFARTN & "\OC")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTN & "\EP") Then
FSO.CreateFolder (rutaPadreFARTN & "\EP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreFARTN & "\CAP") Then
FSO.CreateFolder (rutaPadreFARTN & "\CAP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreGOPMTI & "\" & w) Then
FSO.CreateFolder (rutaPadreGOPMTI & "\" & w)
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreGOPMTI & "\OC") Then
FSO.CreateFolder (rutaPadreGOPMTI & "\OC")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreGOPMTI & "\EP") Then
FSO.CreateFolder (rutaPadreGOPMTI & "\EP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaPadreGOPMTI & "\CAP") Then
FSO.CreateFolder (rutaPadreGOPMTI & "\CAP")
j = j + 1
Else
existente = existente + 1
End If
ElseIf v = "Componente" Then
If Not FSO.FolderExists(rutaCompFARFI & "\" & w) Then
FSO.CreateFolder (rutaCompFARFI & "\" & w)
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARFI & "\OC") Then
FSO.CreateFolder (rutaCompFARFI & "\OC")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARFI & "\EP") Then
FSO.CreateFolder (rutaCompFARFI & "\EP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARFI & "\CAP") Then
FSO.CreateFolder (rutaCompFARFI & "\CAP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARTA & "\" & w) Then
FSO.CreateFolder (rutaCompFARTA & "\" & w)
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARTA & "\OC") Then
FSO.CreateFolder (rutaCompFARTA & "\OC")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARTA & "\EP") Then
FSO.CreateFolder (rutaCompFARTA & "\EP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARTA & "\CAP") Then
FSO.CreateFolder (rutaCompFARTA & "\CAP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARTN & "\" & w) Then
FSO.CreateFolder (rutaCompFARTN & "\" & w)
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARTN & "\OC") Then
FSO.CreateFolder (rutaCompFARTN & "\OC")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARTN & "\EP") Then
FSO.CreateFolder (rutaCompFARTN & "\EP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompFARTN & "\CAP") Then
FSO.CreateFolder (rutaCompFARTN & "\CAP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompGOPMTI & "\" & w) Then
FSO.CreateFolder (rutaCompGOPMTI & "\" & w)
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompGOPMTI & "\OC") Then
FSO.CreateFolder (rutaCompGOPMTI & "\OC")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompGOPMTI & "\EP") Then
FSO.CreateFolder (rutaCompGOPMTI & "\EP")
j = j + 1
Else
existente = existente + 1
End If
If Not FSO.FolderExists(rutaCompGOPMTI & "\CAP") Then
FSO.CreateFolder (rutaCompGOPMTI & "\CAP")
j = j + 1
Else
existente = existente + 1
End If
End If
'-------------------------------------------------------------------'
'---Creación y Asignacion de carpeta para el archivo Excel Padre.---'
'-------------------------------------------------------------------'
Dim fi, tb As String
Dim TabName As String
TabName = rng1.Value
rutaFichas = ActiveWorkbook.Path & "\BBDD\Fichas SGM"
If v = "Padre" Then
If rutaPadreFARFI = rutaFARFI & "\" & "P" & TabName Then
fi = "FAR - FIN.xlsm"
Workbooks.Open Filename:=rutaFichas & "\" & fi
Range("D5").Value = TabName
ActiveSheet.Name = TabName
With ThisWorkbook
.Worksheets(TabName).Copy
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
.Worksheets(TabName).Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
End With
With ThisWorkbook
.Worksheets("Distribucion").Copy
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
.Worksheets("Distribucion").Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=rutaPadreFARFI & "\" & TabName
ActiveWorkbook.Close SaveChanges:=True
k = k + 1
End If
If rutaPadreFARTA = rutaFARTA & "\" & "P" & TabName Then
tb = "FAR - TRIB.xlsm"
Workbooks.Open Filename:=rutaFichas & "\" & tb
Range("D5").Value = TabName
ActiveSheet.Name = TabName
With ThisWorkbook
.Worksheets(TabName).Copy
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
.Worksheets(TabName).Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
End With
With ThisWorkbook
.Worksheets("Distribucion").Copy
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
.Worksheets("Distribucion").Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=rutaPadreFARTA & "\" & TabName
ActiveWorkbook.Close SaveChanges:=True
k = k + 1
End If
If rutaPadreFARTN = rutaFARTN & "\" & "P" & TabName Then
tb = "FAR - TRIB.xlsm"
Workbooks.Open Filename:=rutaFichas & "\" & tb
Range("D5").Value = TabName
ActiveSheet.Name = TabName
With ThisWorkbook
.Worksheets(TabName).Copy
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
.Worksheets(TabName).Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
End With
With ThisWorkbook
.Worksheets("Distribucion").Copy
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
.Worksheets("Distribucion").Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=rutaPadreFARTN & "\" & TabName
ActiveWorkbook.Close SaveChanges:=True
k = k + 1
End If
If rutaPadreGOPMTI = rutaGOPMTI & "\" & "P" & TabName Then
tb = "FAR - TRIB.xlsm"
Workbooks.Open Filename:=rutaFichas & "\" & tb
Range("D5").Value = TabName
ActiveSheet.Name = TabName
With ThisWorkbook
.Worksheets(TabName).Copy
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
.Worksheets(TabName).Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
End With
With ThisWorkbook
.Worksheets("Distribucion").Copy
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
.Worksheets("Distribucion").Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Cells.Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=rutaPadreGOPMTI & "\" & TabName
ActiveWorkbook.Close SaveChanges:=True
k = k + 1
End If
End If
Set rng1 = rng1.Offset(1, 0)
Set rngTipo = rngTipo.Offset(1, 0)
End If
Loop
Workbooks("Consolidado Final.xlsx").Close
Workbooks("Consolidado OC.xlsx").Close
Workbooks("BBDD CT.xlsx").Close
Workbooks("BBDD OC.xlsx").Close
minutosTranscurridos = Format((Timer - inicioTiempo) / 86400, "hh:mm:ss")
Set FSO = Nothing
'Se reactiva la propiedad de actualización.}
Application.ScreenUpdating = True
ActiveWindow.WindowState = xlMaximized 'Se maximiza la ventana para mostrar el menu
End Sub
答案 0 :(得分：1)
以下是如何将代码拆分为有用的VBA组件的示例。将“有用”定义为比你的时间更有效的东西。
Option Explicit
Sub Estructura_Activo_Fijo()
Dim WbEstructura As Workbook
Dim WbX As Workbook
Application.ScreenUpdating = False
If Not GetWorkbook("Estructura.xlsx", WbEstructura) Then GoTo SideExit
If Not GetWorkbook("BBDD\Biblioteca\BBDD Locales\Consolidado Final.xlsx", WbX) Then GoTo SideExit
SideExit:
Application.ScreenUpdating = True
End Sub
Private Function GetWorkbook(ByVal FilePath As String, _
Wb As Workbook) As Boolean
Dim Sp() As String ' split FilePath
Dim Ffn As String ' Full File Name
Dim Fn As String ' File name
Sp = Split(FilePath, "\")
Fn = Sp(UBound(Sp))
On Error Resume Next
Set Wb = Application.Workbooks(Fn)
If Err.Number = 9 Then ' 9 = Suscript out of range
Ffn = ActiveWorkbook.Path & "\" & FilePath
If Len(Dir(Ffn)) = 0 Then
MsgBox "I couldn't find the file" & vbCr & _
FilePath & vbCr & _
"This task must now be abandoned.", _
vbCritical, "Unable to open workbook"
Else
Set Wb = Workbooks.Open(FileName:=Ffn)
End If
End If
GetWorkbook = Not (Wb Is Nothing)
End Function
在这个例子中，我创建了一个打开工作簿的函数。您可以为需要打开的许多工作簿重复调用它。所有工作都在功能中完成。在主程序中，打开两个工作簿只需要两行代码。
您会注意到，该功能本身可以比它作为主要功能的一部分做得更好。它可以告诉你出了什么问题。此外，如果工作簿成功打开，它将返回TRUE，并且您的主程序可以更容易，更透明地根据该事件采取操作。