Error 9, el subíndice está fuera del intervalo, código excel vba
Este código se me ha trabado:
Sub AbrirArchivos()
Dim Archivos As String
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim dupes As Long
Dim maxDupes As Long
Dim dupeWord As String
Dim dupeTie As Boolean
Archivos = Dir("D:\Nueva carpeta\10 semana\*.xls")
Do While Archivos <> ""
Workbooks.Open "D:\Nueva carpeta\10 semana\" & Archivos
Set ws = ThisWorkbook.Sheets("F3") En esta parte sale el error 9
Set rng = ws.Range("x7:x32")
For Each cell In rng
dupes = Application.WorksheetFunction.CountIf(rng, cell)
If dupes > maxDupes Then
maxDupes = dupes
dupeWord = cell.Value
dupeTie = False
End If
If dupes = maxDupes And InStr(1, dupeWord, cell.Value) = False Then
dupeWord = dupeWord & ", " & cell.Value
dupeTie = True
End If
Next cell
If dupeTie = False Then MsgBox dupeWord & "" _
& "appears in the range " & maxDupes & " times."
If dupeTie = True Then MsgBox "The values (" & _
dupeWord & ") appear in the range " & maxDupes & " times."
Worksheets("F3").Cells(38, 24).Value = dupeWord
MsgBox ActiveWorkbook.Name
ActiveWorkbook.Close SaveChanges:=True
Archivos = Dir
Loop
End Sub
2 Respuestas
La hoja F3 si existe, son varios archivos con el mismo formato
Este código funciona al abrir archivo por archivo
Dim Archivos As String
Set ws = ThisWorkbook.Sheets("F3")
Set rng = ws.Range("x7:x32")
For Each cell In rng
dupes = Application.WorksheetFunction.CountIf(rng, cell)
If dupes > maxDupes Then
maxDupes = dupes
dupeWord = cell.Value
dupeTie = False
End If
If dupes = maxDupes And InStr(1, dupeWord, cell.Value) = False Then
dupeWord = dupeWord & ", " & cell.Value
dupeTie = True
End If
Next cell
If dupeTie = False Then MsgBox dupeWord & "" _
& "appears in the range " & maxDupes & " times."
If dupeTie = True Then MsgBox "The values (" & _
dupeWord & ") appear in the range " & maxDupes & " times."
Worksheets("F3").Cells(38, 24).Value = dupeWord
MsgBox ActiveWorkbook.Name
ActiveWorkbook.Close SaveChanges:=TruePero quiero que automáticamente el código se aplique para todos los archivos y no hacerlo uno en uno.
Gracias por su ayuda.
Entonces debe ser con el libro activo.
Thisworkbook es para el archivo que contiene la macro.
Set ws = ActiveWorkbook.Sheets("F3")
Gracias, ya ejecuta todas los archivos, el problema ahora es que se copia la misma palabra (libro de la izquierda) en los tres, cuando en el medio la celda debe estar en blanco y en el libro de la derecha debe aparecer la palabra teléfono.
El código en archivos abiertos uno en uno no ocurre esto.
No conozco la lógica de tu macro.
Pero al final siempre escribes la palabra.
Debes limpiarla al inicio de cada archivo:
dupeWord = ""
Sub AbrirArchivos()
Dim Archivos As String
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim dupes As Long
Dim maxDupes As Long
Dim dupeWord As String
Dim dupeTie As Boolean
'
Archivos = Dir("D:\Nueva carpeta\10 semana\*.xls")
Do While Archivos <> ""
dupeWord = ""
Workbooks.Open "D:\Nueva carpeta\10 semana\" & Archivos
Set ws = ThisWorkbook.Sheets("F3") 'En esta parte sale el error 9
Set rng = ws.Range("x7:x32")
'
For Each cell In rng
dupes = Application.WorksheetFunction.CountIf(rng, cell)
If dupes > maxDupes Then
maxDupes = dupes
dupeWord = cell.Value
dupeTie = False
End If
If dupes = maxDupes And InStr(1, dupeWord, cell.Value) = False Then
dupeWord = dupeWord & ", " & cell.Value
dupeTie = True
End If
Next cell
'
If dupeTie = False Then
MsgBox dupeWord & "" & "appears in the range " & maxDupes & " times."
Else
MsgBox "The values (" & dupeWord & ") appear in the range " & maxDupes & " times."
Worksheets("F3").Cells(38, 24).Value = dupeWord
End If
'
MsgBox ActiveWorkbook.Name
ActiveWorkbook.Close SaveChanges:=True
Archivos = Dir
Loop
End SubY tampoco sé en qué momento la debes escribir. Si dupetie = False o si = True.
Prueba así:
If dupeTie = False Then
MsgBox dupeWord & "" & "appears in the range " & maxDupes & " times."
Else
MsgBox "The values (" & dupeWord & ") appear in the range " & maxDupes & " times."
Worksheets("F3").Cells(38, 24).Value = dupeWord
End IfO así:
If dupeTie = False Then
MsgBox dupeWord & "" & "appears in the range " & maxDupes & " times."
Worksheets("F3").Cells(38, 24).Value = dupeWord
Else
MsgBox "The values (" & dupeWord & ") appear in the range " & maxDupes & " times."
End IfO como la tenías:
If dupeTie = False Then
MsgBox dupeWord & "" & "appears in the range " & maxDupes & " times."
Else
MsgBox "The values (" & dupeWord & ") appear in the range " & maxDupes & " times."
End If
Worksheets("F3"). Cells(38, 24).Value = dupeWordPrueba y me comentas.
Se ha probado con todos, aplica el código correctamente al primer archivo, a los demás si bien hace todo el proceso no establece la palabra y deja en blanco la celda en el que va a salir el resultado, en este caso la celda (38,24)
Tengo que revisar toda la macro y ver por qué no hace lo que necesitas.
Suba a la red tus archivos de prueba. En dropbox o google drive.
Logré hacerla correr, era cambiar dupeWord líneas abajo
Sub AbrirArchivos()
Dim Archivos As String
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim dupes As Long
Dim maxDupes As Long
Dim dupeWord As String
Dim dupeTie As Boolean
'
Archivos = Dir("D:\Nueva carpeta\10 semana\*.xls")
Do While Archivos <> ""
Workbooks.Open "D:\Nueva carpeta\10 semana\" & Archivos
dupeWord=""
Set ws = ActiveWorkbook.Sheets("F3")
Set rng = ws.Range("x7:x32")y lo que sigue del código presentado.