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

Respuesta
2

Ho la y bienvenido a TodoExpertos.

Ese error es porque deberías tener una hoja con el nombre "F3".

Si el nombre de la hoja se encuentra dentro de la celda "F3", entonces debería ser:

Set ws = ThisWorkbook.Sheets(Range("F3").Value)


Nota: Procura agregar el código con el botón insertar código:

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:=True

Pero 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 Sub

Y 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 If

O 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 If

O 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 = dupeWord

Prueba 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.

Respuesta
1

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.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas