Jump to content
Sign in to follow this  
eoscar88

ANSWERED Copiar y pegar datos con varias condiciones

Recommended Posts

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

Share this post


Link to post
Share on other sites

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

 

 

Edited by ikanni

Share this post


Link to post
Share on other sites

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

Share this post


Link to post
Share on other sites

>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

Share this post


Link to post
Share on other sites

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

Share this post


Link to post
Share on other sites

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.

 

Imagen1.png

Share this post


Link to post
Share on other sites

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

 

Edited by ikanni

Share this post


Link to post
Share on other sites

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

 

Share this post


Link to post
Share on other sites

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

 

Share this post


Link to post
Share on other sites

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!!!!

Share this post


Link to post
Share on other sites

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

Share this post


Link to post
Share on other sites

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

 

Share this post


Link to post
Share on other sites
Sign in to follow this  

×
×
  • Create New...

Important Information

Privacy Policy

Ayuda Excel - Madrid, Madrid, ES - Valorada por 6254 personas - Aprender Excel - Total: 4.7 / 5