Cambiar una celda con condicional

[r1004]

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?

[JasallBcn]

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.

[r1004]

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

[JasallBcn]

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 & "\" 

[r1004]

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

[Frank2021]

Hola

Te envío mi solución

Saludos

CambiarBC30.xlsm

[Frank2021]

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

[r1004]

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

[r1004]

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

 

[Frank2021]

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