Extract data from sheet to another

[Villalobos]

Hello,

I would like to ask some help how should I modify the below mentioned code. It is working fine just I need to extend the function a bit.

A Short summary:
The code extract those material numbers from Sheet2 (column F8,G,H) to Sheet1 (C50,D,E) where the stock is above 0 and I would like that if the code could extract the name of the customer also.

Or do you know a simplier code?

The expected results are in yellow background in the attached file (Sheet1).

Public Sub GB()
  Dim oneRange As Range
  Dim aCell As Range
  Dim x, y(), i&, j&, k&
  Dim LastRow As Long
  x = Sheets(2).Range("F8").CurrentRegion.Value
  ReDim y(1 To UBound(x), 1 To 2): j = 1
  With CreateObject("Scripting.Dictionary")
  .CompareMode = 1
  For i = 1 To UBound(x)
  If x(i, 2) > 0 Then
  If .Exists(x(i, 1)) Then
  k = .Item(x(i, 1)): y(k, 2) = y(k, 2) + x(i, 2)
  Else
  j = j + 1: .Item(x(i, 1)) = j
  y(j, 1) = x(i, 1): y(j, 2) = x(i, 2)
  End If
  End If
  Next i
  End With
  With Sheets(1).Range("C49").CurrentRegion.Resize(, 2)
  .ClearContents
  .Resize(j, 2).Value = y()
  End With
  On Error Resume Next
  Set oneRange = Sheets(1).Range("C52:D" & LastRow)
  Set aCell = Sheets(1).Range("C52")
End Sub

Thanks in advance the reply.

 

[Smallman]

Hi

This fixes the issue for you.

Public Sub GB()
    Dim oneRange As Range
    Dim aCell As Range
    Dim x, y(), i&, j&, k&
    Dim LastRow As Long
        x = Sheets(2).Range("F8").CurrentRegion.Value
        ReDim y(1 To UBound(x), 1 To 3): j = 1
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
                For i = 1 To UBound(x)
                    If x(i, 2) > 0 Then
                            If .Exists(x(i, 1)) Then
                                k = .Item(x(i, 1)): y(k, 2) = y(k, 2) + x(i, 2)
                            Else
                                j = j + 1: .Item(x(i, 1)) = j
                                y(j, 1) = x(i, 1): y(j, 2) = x(i, 2): y(j, 3) = x(i, 3)
                            End If
                    End If
                Next i
        End With
        With Sheets(1).Range("C49").CurrentRegion.Resize(, 2)
            .ClearContents
            .Resize(j, 3).Value = y()
        End With
    On Error Resume Next
    Set oneRange = Sheets(1).Range("C52:D" & LastRow)
    Set aCell = Sheets(1).Range("C52")
End Sub

However this coding is over kill IMO. I would use a filter and 3 VBA lines of code to do the same thing with an unnoticeable time difference.

Take care

Smallman

 

[Marc L]

Hi !

Same as Smallman, an advanced filter whatever manual or by code
gives an immediate result !
​

 

[Smallman]

Using Mark's concept this procedure produces the same result.

Sub MoveAdv()
  Sheet2.[F8:H40].AdvancedFilter 2, [D47:D48], [C50]
End Sub

It is worth considering for its simplicity over scripting Dictionaries which are beyond most Excel users.

File attached to prove workings.

Take care

Smallman

 

[Villalobos]

Hello Guys,

Thank you the help!