Macro no ejecuta en otros libros
Hola experto, quisiera pedirte ayuda con lo siguiente pls
tengo un problema con una macro (que junté de otras macros), la cual quisiera que haga esto:
-Del directorio que pegue el archivo me modifique todos los .xls que contenga la carpeta
-De preferencia que ejecute todo sin actualizar la pantalla para que el código se ejecute más rapido
1. Enliste los archivos que tengo en esa carpeta
2.Abra todos los .xls de la lista generada
3. Ejecute macro (cambiar_con_vlookup_metal_y_buy) a cada hoja (Bom) del libro de la lista (que prácticamente es cambiar valores en celdas pero de la hoja Bom)
4. Guarde cambios del libro especifico y cierre ese libro
EL PROBLEMA ES QUE NO ME EJECUTA "cambiar_con_vlookup_metal_y_buy" EN LOS LIBROS DE LA LISTA Y YA ESTOY DESESPERADO... U.u'
esta es la rutina:
Option Explicit
Sub a_todo()
Application.ScreenUpdating = False
Static s As Long, w As Long
Dim v As Long, r As Long, i As Long, strFile As String
Dim fso As Variant, ruta, directorio, ficheros, librostd2 As String
Dim archivo, librostd As String, librodelista As String, libro As String, librostd1 As String
'Listar archivos
Set fso = CreateObject("Scripting.FileSystemObject")
ruta = ActiveWorkbook.Path
Set directorio = fso.GetFolder(ruta)
Set ficheros = directorio.Files
Range("B1").Select
ActiveCell = "Archivo"
Range("B2").Select
For Each archivo In ficheros
If archivo.Name <> ActiveWorkbook.Name Then
ActiveCell = archivo.Name
ActiveCell.Offset(1, 0).Select
End If
Next
Set fso = Nothing
Set directorio = Nothing
Set ficheros = Nothing
'Abrir todos los libros .xls
Dim MiRuta As String, arcact As String, arch As String
MiRuta = ActiveWorkbook.Path
arcact = ActiveWorkbook.Name
arch = Dir(MiRuta & "\*.xls")
Do Until arch = ""
If arch = arcact Then GoTo Salto
Workbooks.Open Filename:=MiRuta & "\" & arch, UpdateLinks:=False
Salto:
arch = Dir
Loop
'APLICAR MACRO A LA LISTA
librostd1 = "S:\SiteData\GDL4\Enclosures\CEC_SESP4\CEC 2011\REFERENCE INFORMATION\STD Validation.xls"
Workbooks.Open Filename:=librostd1, UpdateLinks:=False, ReadOnly:=True
librostd2 = "STD Validation.xls"
librodelista = "aplicar a todos los libros.xls"
For i = 2 To Range("B2").End(xlDown).Row
Windows(librodelista).Activate
libro = Cells(i, 2)
Cells(i, 3).Value = "OK"
Cells(i, 4).Value = w
Windows(libro).Activate
ActiveWorkbook.Sheets("Bom").Select
cambiar_con_vlookup_metal_y_buy
Next
Application.Calculation = xlCalculationAutomatic
Windows(librodelista).Activate
strFile = ActiveWorkbook.FullName
Windows(librostd2).Close
Application.ScreenUpdating = True
End Sub
'CAMBIAR CON VLOOKUP METAL Y BUY
Sub cambiar_con_vlookup_metal_y_buy()
Dim v As Long, r As Long
Static s As Long, w As Long
ActiveWorkbook.Sheets("Bom").Activate
ActiveWorkbook.Sheets("Bom").Select
For r = 2 To 5999 Step 1
If Cells(r, 6).Value <> "" Then w = r
Next r
For r = 2 To w Step 1
If (Cells(r, 6).Value = "Buy" Or Cells(r, 6).Value = "Metal") And (Cells(r, 13).Value = "") Then
Cells(r, 9).Value = ""
Cells(r, 12).Value = "=+VLOOKUP(RC[-9],'S:\SiteData\GDL4\Enclosures\CEC_SESP4\CEC 2011\REFERENCE INFORMATION\[STD Validation.xls]STD Validation'!C1:C11,11,0)"
Cells(r, 12).Select
Selection.Copy
Cells(r, 12).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
s = 0
s = r + 1
Cells(s, 13).Value = "=R[-1]C[-1]*R[-1]C[-2]"
End If
Next r
Calculate
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
ActiveWorkbook.Close savechanges:=True
End Sub
Bueno, de antemano, gracias por leer xD
tengo un problema con una macro (que junté de otras macros), la cual quisiera que haga esto:
-Del directorio que pegue el archivo me modifique todos los .xls que contenga la carpeta
-De preferencia que ejecute todo sin actualizar la pantalla para que el código se ejecute más rapido
1. Enliste los archivos que tengo en esa carpeta
2.Abra todos los .xls de la lista generada
3. Ejecute macro (cambiar_con_vlookup_metal_y_buy) a cada hoja (Bom) del libro de la lista (que prácticamente es cambiar valores en celdas pero de la hoja Bom)
4. Guarde cambios del libro especifico y cierre ese libro
EL PROBLEMA ES QUE NO ME EJECUTA "cambiar_con_vlookup_metal_y_buy" EN LOS LIBROS DE LA LISTA Y YA ESTOY DESESPERADO... U.u'
esta es la rutina:
Option Explicit
Sub a_todo()
Application.ScreenUpdating = False
Static s As Long, w As Long
Dim v As Long, r As Long, i As Long, strFile As String
Dim fso As Variant, ruta, directorio, ficheros, librostd2 As String
Dim archivo, librostd As String, librodelista As String, libro As String, librostd1 As String
'Listar archivos
Set fso = CreateObject("Scripting.FileSystemObject")
ruta = ActiveWorkbook.Path
Set directorio = fso.GetFolder(ruta)
Set ficheros = directorio.Files
Range("B1").Select
ActiveCell = "Archivo"
Range("B2").Select
For Each archivo In ficheros
If archivo.Name <> ActiveWorkbook.Name Then
ActiveCell = archivo.Name
ActiveCell.Offset(1, 0).Select
End If
Next
Set fso = Nothing
Set directorio = Nothing
Set ficheros = Nothing
'Abrir todos los libros .xls
Dim MiRuta As String, arcact As String, arch As String
MiRuta = ActiveWorkbook.Path
arcact = ActiveWorkbook.Name
arch = Dir(MiRuta & "\*.xls")
Do Until arch = ""
If arch = arcact Then GoTo Salto
Workbooks.Open Filename:=MiRuta & "\" & arch, UpdateLinks:=False
Salto:
arch = Dir
Loop
'APLICAR MACRO A LA LISTA
librostd1 = "S:\SiteData\GDL4\Enclosures\CEC_SESP4\CEC 2011\REFERENCE INFORMATION\STD Validation.xls"
Workbooks.Open Filename:=librostd1, UpdateLinks:=False, ReadOnly:=True
librostd2 = "STD Validation.xls"
librodelista = "aplicar a todos los libros.xls"
For i = 2 To Range("B2").End(xlDown).Row
Windows(librodelista).Activate
libro = Cells(i, 2)
Cells(i, 3).Value = "OK"
Cells(i, 4).Value = w
Windows(libro).Activate
ActiveWorkbook.Sheets("Bom").Select
cambiar_con_vlookup_metal_y_buy
Next
Application.Calculation = xlCalculationAutomatic
Windows(librodelista).Activate
strFile = ActiveWorkbook.FullName
Windows(librostd2).Close
Application.ScreenUpdating = True
End Sub
'CAMBIAR CON VLOOKUP METAL Y BUY
Sub cambiar_con_vlookup_metal_y_buy()
Dim v As Long, r As Long
Static s As Long, w As Long
ActiveWorkbook.Sheets("Bom").Activate
ActiveWorkbook.Sheets("Bom").Select
For r = 2 To 5999 Step 1
If Cells(r, 6).Value <> "" Then w = r
Next r
For r = 2 To w Step 1
If (Cells(r, 6).Value = "Buy" Or Cells(r, 6).Value = "Metal") And (Cells(r, 13).Value = "") Then
Cells(r, 9).Value = ""
Cells(r, 12).Value = "=+VLOOKUP(RC[-9],'S:\SiteData\GDL4\Enclosures\CEC_SESP4\CEC 2011\REFERENCE INFORMATION\[STD Validation.xls]STD Validation'!C1:C11,11,0)"
Cells(r, 12).Select
Selection.Copy
Cells(r, 12).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
s = 0
s = r + 1
Cells(s, 13).Value = "=R[-1]C[-1]*R[-1]C[-2]"
End If
Next r
Calculate
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
ActiveWorkbook.Close savechanges:=True
End Sub
Bueno, de antemano, gracias por leer xD
1 respuesta
Respuesta de afbrand
1