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

si alguien tiene alguna referencia para consultar

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

 

 

Editado el el 17 de julio6 años por ikanni

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

>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

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.

Prueba a cambiar el 5 por un 4

(sic)....

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

Explicate un poco mejor, ya que no entendí nada

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.

 

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

 

Editado el el 20 de julio6 años por ikanni

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

 

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

 

Ya lo hice amigo y el resultado es el mismo

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

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

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

 

 

Gracias

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

 

Muchas gracias Ikanni, es la solución que esperaba, tema solucionado