Todos los excell en una misma carpeta.

Unicamente a cambiar una celda de todos los excells de la carpeta. La "BC30" es una celda combinada.

Condicional:

 

Si el valor actual de BC30= "hogares" cambiar el valor de la celda por "infiernos"

Si el valor actual de BC30= "alquileres" cambiar el valor de la celda por "placeres"

Si el valor actual de BC30= "compartir" cambiar el valor de la celda por "genesis"

 

En la celda CB30 solo pueden existir estos valores:" hogares", "alquileres" , "compartir"

Y siempre se quieren cambiar por estas correspondencias:

 

Cita

Si el valor actual de BC30= "hogares" cambiar el valor de la celda por "infiernos"

Si el valor actual de BC30= "alquileres" cambiar el valor de la celda por "placeres"

Si el valor actual de BC30= "compartir" cambiar el valor de la celda por "genesis"

Alguien sabe como hacerlo de forma masiva?

Editado el el 17 de enero3 años por r1004

Buenas , soy nuevo en esto de Macros , pero investigando he dado esta solución ,

El macro funciona con el directorio "C:\Excel\" 

la llamada al Macro es " Analizar_archivos" desde Libro.xlsm

Option Explicit
Dim ArchivoAbrir As Excel.Workbook
Sub Analizar_Archivos()

    Dim Dir, Carpeta, Archivo As Object
    Dim Ruta As String
    Dim Listado() As Variant
       
    Set Dir = CreateObject("Scripting.FileSystemObject")
    
    Ruta = "C:\Excel\" ' ruta donde mirar
    On Error GoTo Error
    Set Carpeta = Dir.GetFolder(Ruta)

    For Each Archivo In Carpeta.Files ' recorremos los archivos de la carpeta
        If InStr(1, Archivo.Name, "~$") = 0 And _
         InStr(1, Archivo.Name, "xlsm") = 0 And _
         Archivo.Name <> "C:\Excel\Libro.xlsm" Then ' exclusiones
         
         AbrirarchivoExterno (Ruta & Archivo.Name) ' abrimos el archivo
        End If
    Next

    Exit Sub
    
Error:
    MsgBox "Ruta inexistente", vbCritical

End Sub


Sub AbrirarchivoExterno(Archivo)
On Error Resume Next

If Len(Archivo) > 0 Then
    Set ArchivoAbrir = Workbooks.Open(Archivo)
     Workbooks.Open(Archivo).Application.Visible = False ' abrimos el archivo en modo invisible
     Comprueba ' comprobamos el archivo abierto
     Cerrar (Archivo) ' cerramos el archivo abierto
End If

End Sub

Sub Cerrar(Archivo)

Set ArchivoAbrir = Workbooks.Open(Archivo)
ArchivoAbrir.Save
ArchivoAbrir.Close

End Sub

Sub Comprueba()

Dim Texto As String

Texto = Range("Bc30").Value


Select Case Texto

Case Is = "hogares"
 Range("bc30").Value = "infiernos"
Case Is = "alquileres"
 Range("bc30").Value = "placeres"
Case Is = "compartir"
 Range("bc30").Value = "genesis"
 Case "infiernos", "placeres", "genesis"
 Case Else
 Range("Bc30").Value = ""
End Select

End Sub

 

 suerte.

Hola,

 

No me funciona.

 

Sale este error.

 

Seria posible tambien no tener que editar la ruta cada vez y que coja la ruta donde esta el xlsm?

 

Muchas gracias

el error es que copiaste el codigo dentro del boton , borra la 1º linea  : private sub . . . .

para que coja la ruta del directorio actual , cambia ..

 Ruta = "C:\Excel\"  por :

Ruta = ActiveWorkbook.Path & "\" 

Hola,

 

No funciona.

 

Cuando le doy a "play" desde visul basic aparecen dos programas:

 

Analizar archivos y Comprueba.

 

El primero abre todos los archivos y los cierra.

 

El segundo no hace nada.

 

Doy a play de nuevo y ya no me deja elegir entre dos programas. Ejecuta abriendo archivos, pero tampoco cambia los valores.

 

No se que puede estar pasando

Hola

Te envío mi solución

Saludos

CambiarBC30.xlsm

Hola,

olvidé comentar que para que funcione debes copiar el fichero enviado en el directorio donde están los ficheros que quieres cambiar la celda BC30

Saludos

Muchas gracias.

 

Sigue sin funcionar.

 

Adjunto excells para testar porque no encuentro el problema.

 

estas son las correspondencias reales y editadas que he utilizado.

 

 Select Case r.Value
          Case "GRAUNNER 650 WALKARROUND": r.Value = "RITCHIE"
          Case "V2 BOAT 5.0": r.Value = "5 TIMES"
          Case "QUICKSYLVER 455": r.Value = "4 TIMES"
          Case "SACS SC 25 DREAM": r.Value = "FAIGA"
        End Select

 

21-334.xlsx 21-335.xlsx 21-336.xlsx 21-337.xlsx 21-338.xlsx 21-339.xlsx 21-340.xlsx 21-341.xlsx

estas son las correspondencias del otro programa de Jasal

 

Select Case Texto

Case Is = "RITCHIE"
 Range("bc30").Value = "GRAUNNER 650 WALKARROUND"
Case Is = "5 TIMES"
 Range("bc30").Value = "V2 BOAT 5.0"
Case Is = "4 TIMES"
 Range("bc30").Value = "QUICKSYLVER 455"
 Case Is = "FAIGA"
 Range("bc30").Value = "SACS SC 25 DREAM"
 Case "RITCHIE", "5 TIMES", "4 TIMES", "FAIGA"
 Case Else
 Range("Bc30").Value = ""
End Select

 

Hola 

La razón por la que no te funciona es porque nos estás diciendo que la casilla a cambiar es BC30, cuando en realidad es la casilla B30.

Así si cambias BC30 por B30, en el código, ya te funcionará. 

Saludos