Macro para evaluar y encontrar un valor de una celda de una columna para copiar otras celdas de la fila.

Olé usted si que programa a la vieja escuela ja!

Como dato extra: yo no recomiendo la declaración integer con Dim var% es programación obsoleta y creo que solo sigue existiendo en VB.NET y estoy seguro que algún día lo descontinuarán por completo, pero vale, vayamos a su pregunta...

Para chequear si una celda contiene un "sub-texto" dentro de un "texto" puede usar la función InStr y la sintaxis es la siguiente:

Resultado = InStr(1, TEXTO, SUB-TEXTO)

donde resultado seria una variable integer ya que la función InStr devuelve un integer. Si este tal "resultado" es igual a 0 significa que el sub-texto NO fue encontrado en el texto. Si este resultado es mayor a 0 significa que el sub-texto SÍ fue encontrado en el texto.

Algunos otros consejos:

1- Le felicito la idea de pasar un Array en lugar de usar los métodos .Copy & .Paste pero veo que en su código agranda el array al tamaño de la tabla, sin embargo agrega items basados en condiciones, por lo que el array quedará mas grande de lo que realmente es.

2- Por que hacer a VBA trabajar de más. Usted pune c1 = Range("A1"). Column cuando todos sabemos que la columna A siempre es 1 la C siempre es 3, no seria mejor poner C1 = 1 y C2 = 3.

"A los lenguajes de programación les encantan los números y odian las letras"

Hola! Antes que nada muchas gracias por responder.

En estos días le agregue la función Instr así como me lo dice

For fr = fu To uf
celda = Cells(fr, c1)
resultado = InStr( celda, '"observaciones")
If resultado > 0 Then
fm = fm + 1
m(fm, 1) = Cells(fr, c1)
m(fm, 2) = Cells(fr, c2)
m(fm, 3) = Cells(fr, c3)
m(fm, 4) = Cells(fr, c4)
m(fm, 5) = Cells(fr, c5)
m(fm, 6) = Cells(fr, c6)
m(fm, 7) = Cells(fr, c7)
End If
Next

If fm = 0 Then Exit Sub

Pero lamentablemente me sigue copiando las columnas completas sin haber evaluado la columna en donde busca la palabra observaciones.

Nota: soy nueva en el desarrollo de macros entonces solo me guio de otras personas que hayan preguntado sobre el mismo problema, es por eso que tiene como de todo.

Ojala me pudieras ayudar! Gracias de antemano

En su primer post indicó que la palabra Observaciones estaría en la columna BA, sin embargo su código dice: celda = Cells(fr, c1)

(Que por cierto debería indicar que quiere de ella: celda = Cells(fr, c1).Value)

Me pregunto: ¿La variable c1 hace referencia a la columna BA? Porque según su código en el primer post la variable c1 almacena la columna A, no BA

Así que:

-Asegúrese que la variable "celda" es de tipo String

-Que la variable "resultado" es de tipo Integer

-Y que la variable c1 apunta a la columna BA (columna 53)

Hola! te comento que en el primer post use un libro con datos de prueba y unas celdas de prueba, para no dañar mi archivo original, pero ya he hecho copia, para trabajar en el original.

te adjunto la macro, con mi logica pero me marca error en "celda= fr.value".

tambien te  comento que vi otro ejemplo que es el siguiente:

pero con este no itera, encuentra una celda con el # y ahi se queda

For each celda In rng(columna a evaluar)

valor= celda.value

if instr(valor, "#")

entonces hice los mismo con la macro copiar. pero no me funciono :/ y la verdad no se cual se el error.

Sub copiar()

'columnas de donde se copiara las filas
Dim c1, c2, c3, c4, c5, c6, c7
c1 = Range("A1").Column
c2 = Range("C1").Column
c3 = Range("D1").Column
c4 = Range("G1").Column
c5 = Range("I1").Column
c6 = Range("K1").Column
c7 = Range("P1").Column
' variables a usar
Dim r As Range, fu, uf, fr, 
Dim m(), fm
'columna en donde se buscara el #
Set r = Range("AZ1").CurrentRegion
' son 7 columnas las que se copiaran cuando encuentre un # en una celda de la columna az1 copiara las columnas que pertenezcan a la fila
ReDim m(r.Rows.Count, 7)
Dim celda As String
'recorre la columna en donde se buscara celda por celda un #
' fu tiene el valor de 1, que es en donde iniciara
fu = r.Row
'uf tiene el valor de 2777, es el tamaño que tiene la columna
uf = fu + r.Rows.Count - 1
' recorrera desde celda 1 hasta  2777
For fr = fu To uf
'la variable celda evaluara la busqueda del recorrido de la columna
celda = fr.Value
' si en celda se encuentra un #, entonces copiara la fila de donde se haya encontrado, por ejemplo si en el
'recorrido se encontro un # en la celda Az50, entonces copiara A50,C50,D50,G50,G50,I50,K50,P50
'que son c1,c2,c3,c4,c5,c6 y c7 respectivamente,
If InStr(celda, "#") > 0 Then
'la variable fm la utilizo para iterar cada celda
fm = fm + 1
m(fm, 1) = fr(celda, c1)
m(fm, 2) = fr(celda, c2)
m(fm, 3) = fr(celda, c3)
m(fm, 4) = fr(celda, c4)
m(fm, 5) = fr(celda, c5)
m(fm, 6) = fr(celda, c6)
'm(fm, 6) = CLng(CDate(Cells(fr, c6)))
m(fm, 7) = fr(celda, c7)
End If
Next

If fm = 0 Then Exit Sub

Dim hs As Worksheet, filas, colus
Set hs = Sheets("H2")
filas = hs.Range("az1").Row
colus = hs.Range("az1").Column
'hs.Range("REMP").Resize(Rows.Count - filas, Columns.Count - colus).ClearContents
hs.Select

'columnas de las hoja2 a donde se pegaran los datos

c1 = Range("A1").Column
c2 = Range("B1").Column
c3 = Range("C1").Column
c4 = Range("G1").Column
c5 = Range("F1").Column
c6 = Range("E1").Column
c7 = Range("L1").Column
'selecciono la hoja
hs.Select
MsgBox "Continuar ..."
fm = 0
'con la hoja dos
With hs
For fr = filas To r.Rows.Count + filas - 1
fm = fm + 1
.Cells(fr, c1) = m(fm, 1)
.Cells(fr, c2) = m(fm, 2)
.Cells(fr, c3) = m(fm, 3)
.Cells(fr, c4) = m(fm, 4)
.Cells(fr, c5) = m(fm, 5)
.Cells(fr, c6) = m(fm, 6)
.Cells(fr, c7) = m(fm, 7)
Next
End With

End Sub

De antemano muchas Gracias!!!

Si puedes, sube el libro a alguna nube y compártelo, así cuando llegue a casa lo reviso y te lo arreglo. Ahora estoy desde el celular.

Hola otra vez,  mira te adjunto otra macro que hice, creo yo se entiende mejor pero hace exactamente lo mismo que la anterior macro, solo copia y no evalua la columna que contiene el caracter.

sobre el archivo, te puedo adjuntar uno de prueba?. Lo que pasa que son datos confidenciales.

te anexo la macro.

Sub copiar()
Set h1 = Worksheets("Hoja1")
Set h2 = Worksheets("Hoja2")
    Set origen = Range("az1").CurrentRegion
   With origen
 Dim m(), fm
ReDim m(origen.Rows.Count, 7)
filas = .Rows.Count
x = 1
     For i = 1 To filas
    'texto = .Cells(i, 1).Value
    On Error Resume Next
   buscar = InStr(texto, "#")
    If buscar > 0 Then
        x = x + 1
         .Range("A1").Cells(i, 1).Value = m(x, 1)
        .Range("C1").Cells(i, 2).Value = m(x, 2)
        .Range("D1").Cells(i, 3).Value = m(x, 3)
        .Range("G1").Cells(i, 4).Value = m(x, 4)
        .Range("I1").Cells(i, 5).Value = m(x, 5)
        .Range("K1").Cells(i, 6).Value = m(x, 6)
        .Range("P1").Cells(i, 7).Value = m(x, 7)
        With h2
    .Range("A1").Cells(n, 1).Value = m(x, 1)
    .Range("B1").Cells(n, 2).Value = m(x, 2)
    .Range("C1").Cells(n, 3).Value = m(x, 3)
    .Range("G1").Cells(n, 4).Value = m(x, 4)
    .Range("F1").Cells(n, 5).Value = m(x, 5)
    .Range("E1").Cells(n, 6).Value = m(x, 6)
    .Range("L1").Cells(n, 7).Value = m(x, 7)
        End With
    End If
    On Error GoTo 0
    Next
End With
MsgBox "proceso terminado"
End Sub

Si, claramente puede ser uno de prueba, con la estructura igual o muy parecida al libro real, así me ahorras trabajo de inventarme datos y adivinanzas.

No quiero decir que la macro este mal, pero no es el estilo con el que yo suelo programar en VBA y no podría estar seguro si tu macro funciona o no, especialmente si usas "On Error Resume Next" que de todas las formas posibles de manejar errores en VBA, esta es la peor sin duda.

Envíame un archivo con información ficticia y te lo devuelvo con mi macro, y ahí veras como lo hice y tomaras alguna idea.

https://onedrive.live.com/?authkey=%21AElPw%2DtA91UlLPE&id=1DBFAB5725050BC0%21124&cid=1DBFAB5725050BC0