Copiar y pegar datos con varias condiciones

eoscar88 · el 11 de julio

Hola buen día, nueva mente necesito de a su valioso apoyo, requiero de una macro que me permita copiar datos de una hoja de acuerdo con varias condiciones en otra hoja, necesito actualizar un stock y no deben aparecer los lotes que ya salieron, dentro del archivo adjunto les muestro tres hojas de calculo, donde vienen las especificaciones.

espero que alguien pueda apoyarme, de antemano muchas gracias

EYS-STOCK.xlsx

eoscar88 · el 16 de julio

si alguien tiene alguna referencia para consultar

ikanni · el 17 de julio

Hola

Prueba esta macro, a ver sí es lo que buscas..

Colócala en un módulo indepediente y la llamas desde donde necesites

Sub ActualizaExistencias()
   Dim c As Range, Registros As Object
   Dim celda, x As Long
   On Error Resume Next
   Set Registros = CreateObject("Scripting.Dictionary")
   Set c = Hoja3.Range("B3:B" & Hoja1.Range("B" & Rows.Count).End(xlUp).Row)
   For Each celda In c
      With celda
         If Len(celda.Offset(, 5)) <> 0 Then
            Registros.Add .Text & .Offset(, 1).Text & .Offset(, 2).Text, .Offset(, 6).Text
         End If
      End With
   Next
   Set c = Hoja1.Range("B3:B" & Hoja1.Range("B" & Rows.Count).End(xlUp).Row)
   For Each celda In c
      With celda
      If Registros.Exists(.Text & .Offset(, 1).Text & .Offset(, 2).Text) Then _
               .Offset(, 4) = Registros(.Text & .Offset(, 1).Text & .Offset(, 2).Text)
      End With
   Next
   Set Registros = Nothing
   MsgBox "Existencias actualizadas"
End Sub

eoscar88 · el 17 de julio

Hola ikanni, muchas gracias por tu respuesta, solo falta un detalle, al momento de actualizar, los registros que quedan en ceros, deben desaparecer y los registros con existencias, deben ocupar el lugar correspondiente, te anexo nuevamente el archivo con la macro integrada, agradezco mucho tu tiempo y conocimientos.

EYS-STOCK-2.xlsm

ikanni · el 18 de julio

>Hola

Pues sí te hubieses esforzado un poco lo podrías haber arreglado tu, salvo que hagas un copia pega sin mirar lo que hace y sí es así pues ....

con cambiar un numero funciona como tu quieres.

Y te voy a dar una ayudita. Hay que cambiarlo en esta linea

If Len(celda.Offset(, 5)) <> 0 Then

Ala curratelo un poco

eoscar88 · el 18 de julio

Hola ikanni, agradezco la llamada de atención, pero sucede que no se nada de programación, solo se entrar al VBA e insertar módulos.

ikanni · el 19 de julio

Prueba a cambiar el 5 por un 4

(sic)....

eoscar88 · el 19 de julio

Hola Ikanni, ya probe cambiando varios términos

If Len(celda.Offset(, 5)) <> 0 Then hice el cambie el valor en esta línea y el resultado es el mismo
Registros.Add .Text & .Offset(, 1).Text & .Offset(, 2).Text, .Offset(, 6).Text Este termino se refiere a la columna de la hoja 3 que va a pegar en la hoja activa

ikanni · el 19 de julio

Explicate un poco mejor, ya que no entendí nada

eoscar88 · el 19 de julio

me refiero a que haciendo el cambio en linea que me indicas, los registros quedan en el mismo lugar y lo que requiero es que los registros que quedan en ceros, deben desaparecer y los registros con existencias, deben ocupar el lugar correspondiente.

ikanni · el 20 de julio

A ver esto

Sub ActualizaExistencias()
   Dim c As Range, Registros As Object
   Dim celda
   On Error Resume Next
   Set Registros = CreateObject("Scripting.Dictionary")
   Set c = Hoja3.Range("B3:B" & Hoja1.Range("B" & Rows.Count).End(xlUp).Row)
   For Each celda In c
      With celda
         If Len(.Offset(, 4)) <> 0 And (.Offset(, 5) - .Offset(, 4) <> 0) Then
            Registros.Add .Text & .Offset(, 1).Text & .Offset(, 2).Text, .Offset(, 6).Text
         End If
      End With
   Next
   Set c = Hoja1.Range("B3:B" & Hoja1.Range("B" & Rows.Count).End(xlUp).Row)
   For Each celda In c
      With celda
         If Registros.Exists(.Text & .Offset(, 1).Text & .Offset(, 2).Text) Then
            .Offset(, 4) = Registros(.Text & .Offset(, 1).Text & .Offset(, 2).Text)
         Else
            .Offset(, 4) = 0: .Offset(, 3) = "": .Offset(, 2) = ""
         End If
      End With
   Next
   Set Registros = Nothing
   MsgBox "Existencias actualizadas"
End Sub

eoscar88 · el 22 de julio

Hola Ikanni, ya inserte la macro y en efecto elimina los registros que quedan en ceros, pero los registros con existencia, deben ocupar las celdas de los registros eliminados, como se ve en la imagen.

agradezco tu apoyo Ikanni

ikanni · el 22 de julio

Cambia lo que hay por esto

...
For Each celda In c
      With celda
         If Registros.Exists(.Text & .Offset(, 1).Text & .Offset(, 2).Text) Then
            .Offset(, 4) = Registros(.Text & .Offset(, 1).Text & .Offset(, 2).Text)
         Else
            .Offset(, 4) = 0
         End If
      End With
Next
...

eoscar88 · el 22 de julio

Ya lo hice amigo y el resultado es el mismo

ikanni · el 23 de julio

Bueno lo que te puse ayer no funciona, pero es que ya no entiendo nada?.

Hoy he hecho pruebas y me ratifico que esto que te puse mas arriba FUNCIONA como quieres.

En 20/7/2019 at 8:24 , ikanni dijo:

A ver esto


Sub ActualizaExistencias()
   Dim c As Range, Registros As Object
   Dim celda
   On Error Resume Next
   Set Registros = CreateObject("Scripting.Dictionary")
   Set c = Hoja3.Range("B3:B" & Hoja1.Range("B" & Rows.Count).End(xlUp).Row)
   For Each celda In c
      With celda
         If Len(.Offset(, 4)) <> 0 And (.Offset(, 5) - .Offset(, 4) <> 0) Then
            Registros.Add .Text & .Offset(, 1).Text & .Offset(, 2).Text, .Offset(, 6).Text
         End If
      End With
   Next
   Set c = Hoja1.Range("B3:B" & Hoja1.Range("B" & Rows.Count).End(xlUp).Row)
   For Each celda In c
      With celda
         If Registros.Exists(.Text & .Offset(, 1).Text & .Offset(, 2).Text) Then
            .Offset(, 4) = Registros(.Text & .Offset(, 1).Text & .Offset(, 2).Text)
         Else
            .Offset(, 4) = 0: .Offset(, 3) = "": .Offset(, 2) = ""
         End If
      End With
   Next
   Set Registros = Nothing
   MsgBox "Existencias actualizadas"
End Sub

Suerte amigo!!!!

eoscar88 · el 23 de julio

Ikanni, agradezco tu tiempo y conocimientos en verdad es muy valioso para mi, creo que esta complicado el asunto, no puedo subir archivos por que la plataforma no me permite hacerlo, pero te dejo el link de una imagen son señalamientos de lo que no pude explicarte, agradezco tu apoyo y si quieres hasta ahí la dejamos.

muchas gracias

https://www.dropbox.com/s/c1785faic9zpw4b/Imagen2.png?dl=0

eoscar88 · el 17 de agosto

Hola buen día, alguien podrá apoyarme para terminar de solucionar este tema.

Gracias

ikanni · el 18 de agosto

Prueba esto

Sub ActualizaExistencias()
   Dim c As Range, Registros As Object
   Dim celda
   Set c = Hoja1.Range("D3:F" & Hoja1.Range("c" & Rows.Count).End(xlUp).Row)
   c.ClearContents
   On Error Resume Next
   Set Registros = CreateObject("Scripting.Dictionary")
   Set c = Hoja3.Range("B3:B" & Hoja1.Range("B" & Rows.Count).End(xlUp).Row)
   For Each celda In c
      With celda
         If CInt(.Offset(, 6)) > 0 Then
            Registros.Add .Text & .Offset(, 1).Text & "@" & _
                  .Offset(, 2).Text & "@" & .Offset(, 3).Text, .Offset(, 6).Text
         End If
      End With
   Next
   Set c = Hoja1.Range("B3:B" & Hoja1.Range("B" & Rows.Count).End(xlUp).Row)
   For Each celda In c
      With celda
         For Each key In Registros.Keys
            Dim mArray
            mArray = Split(key, "@")
            If mArray(0) = .Text & .Offset(, 1).Text Then
               .Offset(, 2).Value = mArray(1)
               .Offset(, 3).Value = mArray(2)
               .Offset(, 4).Value = Registros(key)
               Registros.Remove (key)
               Exit For
            End If
         Next key
      End With
   Next
   Set Registros = Nothing
   MsgBox "Existencias actualizadas"
End Sub