VBA searching for numbers and copying the ones next to it

[ASadStudent]

Hello Everyone, I am trying to automate the copy and paste proces. The things that need to be copied is the amount of times a product is sold. And the way I can find these products is by the code that they are assigned. All products that aren't sold won't show up in the file so I also need to figure out a way to skip numbers that aren't in the file.
These products have a specific code with which I am trying to find them and then copy the number of times sold which is 4 spaces to the right.

For example the code is in the A columm and consists of 4 digits (3000, 3001, 3002 etc). Then the number of times it is sold is in E4.
Can anyone help me find out how to do this ?
Thank you very much for helping me figure this out

 

[ouvay]

Hello, I would need a little more information to get this done right...

- you said you are looking to copy paste.. but you haven't mentioned where you would like to have the result pasted (New workbook/ new sheet)?
- What is the sheet name?
- products that aren't sold aren't in the source data? if so then why do you need to skip something that isn't there? (Please clarify)
- to my understanding ... the final result would be

Product ID	Times Sold
3000	2
3001	3

Correct?

would you be willing to share some sample data?

In the meanwhile, please test this bit of code to see if this works.. this assumes that the data is on sheet1 and the end result is going to be on a new workbook.

Option Base 1
Option Explicit

Sub ASadStudent_CopyPaste()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim data As Variant, lr As Long, result As Variant, n As Long, rw As Long
    ReDim data(1, 4) As Variant
   
    lr = ws.Cells(Rows.Count, 1).End(3).Row
    data = ws.Cells(1, 1).Resize(lr, 4).Value
    ReDim result(UBound(data), 2) As Variant
   
    For rw = LBound(data) To UBound(data)
        If data(rw, 4) <> 0 Then
            n = n + 1
            result(n, 1) = data(rw, 1)
            result(n, 2) = data(rw, 4)
        End If
    Next rw
   
    result = ReDimPreserve(result, n, 2)
    Workbooks.Add.Worksheets(1).Cells(1, 1).Resize(UBound(result), 2).Value = result
End Sub

Private Function ReDimPreserve(ArrayNameToPreserve, NewRowUbound, NewColumnUbound)
    Dim OldRowUbound As Long, OldColumnUbound As Long, NewRow As Long, NewColumn As Long
    ReDimPreserve = False

    If IsArray(ArrayNameToPreserve) Then
        ReDim NewArrayNameToPreserve(NewRowUbound, NewColumnUbound)
        OldRowUbound = UBound(ArrayNameToPreserve, 1)
        OldColumnUbound = UBound(ArrayNameToPreserve, 2)

        For NewRow = LBound(ArrayNameToPreserve, 1) To NewRowUbound
            For NewColumn = LBound(ArrayNameToPreserve, 2) To NewColumnUbound
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then
                    NewArrayNameToPreserve(NewRow, NewColumn) = ArrayNameToPreserve(NewRow, NewColumn)
                End If
            Next
        Next

        If IsArray(NewArrayNameToPreserve) Then ReDimPreserve = NewArrayNameToPreserve
    End If
End Function

 

[ouvay]

That bit of code is definitely overkill for copy paste... but sorry not sorry lol

 

[HaHoBe]

Hi there,

any chance to use a Pivottable on your data?

Ciao,
Holger

 

[ouvay]

Hello, I would need a little more information to get this done right...

- you said you are looking to copy paste.. but you haven't mentioned where you would like to have the result pasted (New workbook/ new sheet)?
- What is the sheet name?
- products that aren't sold aren't in the source data? if so then why do you need to skip something that isn't there? (Please clarify)
- to my understanding ... the final result would be

Product ID	Times Sold
3000	2
3001	3

Correct?

would you be willing to share some sample data?

In the meanwhile, please test this bit of code to see if this works.. this assumes that the data is on sheet1 and the end result is going to be on a new workbook.

Option Base 1
Option Explicit

Sub ASadStudent_CopyPaste()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim data As Variant, lr As Long, result As Variant, n As Long, rw As Long
    ReDim data(1, 4) As Variant
  
    lr = ws.Cells(Rows.Count, 1).End(3).Row
    data = ws.Cells(1, 1).Resize(lr, 4).Value
    ReDim result(UBound(data), 2) As Variant
  
    For rw = LBound(data) To UBound(data)
        If data(rw, 4) <> 0 Then
            n = n + 1
            result(n, 1) = data(rw, 1)
            result(n, 2) = data(rw, 4)
        End If
    Next rw
  
    result = ReDimPreserve(result, n, 2)
    Workbooks.Add.Worksheets(1).Cells(1, 1).Resize(UBound(result), 2).Value = result
End Sub

Private Function ReDimPreserve(ArrayNameToPreserve, NewRowUbound, NewColumnUbound)
    Dim OldRowUbound As Long, OldColumnUbound As Long, NewRow As Long, NewColumn As Long
    ReDimPreserve = False

    If IsArray(ArrayNameToPreserve) Then
        ReDim NewArrayNameToPreserve(NewRowUbound, NewColumnUbound)
        OldRowUbound = UBound(ArrayNameToPreserve, 1)
        OldColumnUbound = UBound(ArrayNameToPreserve, 2)

        For NewRow = LBound(ArrayNameToPreserve, 1) To NewRowUbound
            For NewColumn = LBound(ArrayNameToPreserve, 2) To NewColumnUbound
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then
                    NewArrayNameToPreserve(NewRow, NewColumn) = ArrayNameToPreserve(NewRow, NewColumn)
                End If
            Next
        Next

        If IsArray(NewArrayNameToPreserve) Then ReDimPreserve = NewArrayNameToPreserve
    End If
End Function

Option Base 1
Option Explicit

Sub ASadStudent_CopyPaste()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim data As Variant, lr As Long, result As Variant, n As Long, rw As Long
   
    lr = ws.Cells(Rows.Count, 1).End(3).Row
    data = ws.Cells(1, 1).Resize(lr, 5).Value
    ReDim result(UBound(data), 2) As Variant
   
    For rw = LBound(data) To UBound(data)
        If data(rw, 5) <> 0 Then
            n = n + 1
            result(n, 1) = data(rw, 1)
            result(n, 2) = data(rw, 5)
        End If
    Next rw
   
    result = ReDimPreserve(result, n, 2)
    Workbooks.Add.Worksheets(1).Cells(1, 1).Resize(UBound(result), 2).Value = result
End Sub

Private Function ReDimPreserve(ArrayNameToPreserve, NewRowUbound, NewColumnUbound)
    Dim OldRowUbound As Long, OldColumnUbound As Long, NewRow As Long, NewColumn As Long
    ReDimPreserve = False

    If IsArray(ArrayNameToPreserve) Then
        ReDim NewArrayNameToPreserve(NewRowUbound, NewColumnUbound)
        OldRowUbound = UBound(ArrayNameToPreserve, 1)
        OldColumnUbound = UBound(ArrayNameToPreserve, 2)

        For NewRow = LBound(ArrayNameToPreserve, 1) To NewRowUbound
            For NewColumn = LBound(ArrayNameToPreserve, 2) To NewColumnUbound
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then
                    NewArrayNameToPreserve(NewRow, NewColumn) = ArrayNameToPreserve(NewRow, NewColumn)
                End If
            Next
        Next

        If IsArray(NewArrayNameToPreserve) Then ReDimPreserve = NewArrayNameToPreserve
    End If
End Function

There was an error ... fixed it

 

[ASadStudent]

Thanks a lot for replying.
I will clarify it a bit more for you.
I have 2 different excel files.
And I need to bring the sale amounts from file 1 called "Omzet" to another file called "Maandafsluiting".
These files look like this:

Omzet:

Maandafsluiting:

And I want to copy paste the numbers under "Amount of times sold" from "omzet" to the yellow parts of "Maandafsluiting".
And the file called "maandafsluiting" has all the product numbers, but the file called "omzet" only has the product numbers of the ones that were actually sold.
So I need to create a code that can read the product number and place the amount of times sold in the correct yellow space based on the product number.

 

[ouvay]

Give this a go

Option Base 1
Option Explicit

Sub ASadStudent_CopyPaste()
    Dim omzet As Worksheet: Set omzet = Workbooks.Item("Omzet").Sheets("Sheet1")
    Dim Maandafsluiting As Worksheet: Set Maandafsluiting = Workbooks.Item("Maandafsluiting").Sheets(1)
    
    Dim data As Variant, lr As Long, d As Object, key As String, rw As Long
   
    lr = omzet.Cells(Rows.Count, 1).End(3).Row
    data = omzet.Cells(1, 1).Resize(lr, 5).Value
    
    Set d = CreateObject("Scripting.Dictionary")
    
    For rw = LBound(data) To UBound(data)
        If data(rw, 5) <> 0 Then
            key = data(rw, 1)
            If Not d.exists(key) Then
                d(key) = data(rw, 5)
            End If
        End If
    Next rw
    
    lr = Maandafsluiting.Cells(Rows.Count, 1).End(3).Row
    data = Maandafsluiting.Cells(1, 1).Resize(lr, 7).Value
       
    For rw = LBound(data) To UBound(data)
        key = data(rw, 1)
        If d.exists(key) Then
            data(rw, 7) = d(key)
        End If
    Next rw
   
    Maandafsluiting.Cells(1, 7).Resize(UBound(data)).Value = Application.Index(data, 0, 7)
End Sub

Hope this works, if this doesn't I'm going to need specifics about your sheets and ranges
For example..

workbook : omzet
sheet name : "Sheet 1"
look up range : "Column A"
look up value : "Column E"

and so on ...
let me know how it goes

 

[HaHoBe]

Hi,

as I don´t know what you call 'files' I set it up to be in one workbook. And I must admit that pictures could be worth more than a thousand words if you had at least included the column headers.

MrE_161300C 1220339 _221031_115900.xlsm
	A	B	C	D	E
1	Product number				Amount of times sold
2	3116				185
3	3117				175
4	3101				337
5	3106				246
6	3111				19
7	3121				1
8
9	4006				56
10	4001				980
11	4004				39
12
13	3507				29
14	3508				30
15	3509				124
16	3510				194
17	3502				25
Omzet

MrE_161300C 1220339 _221031_115900.xlsm
	A	B	C	D	E	F	G
1	Product number						Amount of times sold
2	3116						185
3	3117						175
4	3101						337
5	3106						246
6	3111						19
7	3121						1
8	3130
9	3104
10	3102
11
12	4006						56
13	4001						980
14	4003
15	4004						39
16
17	3507						29
18	3508						30
19	3501
20	3504
21	3509						124
22	3511
23	3510						194
24	3502						25
Maandafsluiting

Code goes into a standard module, adjust columns to suit:

Sub MrE161300C()
'https://www.mrexcel.com/board/threads/vba-searching-for-numbers-and-copying-the-ones-next-to-it.1220339
  Dim varMatch                  As Variant
  Dim lngRow                    As Long
  Dim blnMatch                       As Boolean
  Dim wsData                    As Worksheet
  Dim wsTarget                  As Worksheet
  
  Const clngColumnToCompare     As Long = 1
  Const cstrColTarget           As String = "G"
  Const cstrColData             As String = "E"
  
  Application.ScreenUpdating = False
  Set wsData = Sheets("Omzet")
  Set wsTarget = Sheets("Maandafsluiting")
   
  For lngRow = 2 To wsData.Cells(Rows.Count, clngColumnToCompare).End(xlUp).Row
    blnMatch = False
    If Not IsEmpty(wsData.Cells(lngRow, clngColumnToCompare)) Then
      varMatch = Application.Match(wsData.Cells(lngRow, clngColumnToCompare).Value, wsTarget.Columns(clngColumnToCompare), 0)
      If Not IsError(varMatch) Then
        blnMatch = True
      End If
    End If
    If blnMatch Then
      wsTarget.Cells(varMatch, cstrColTarget).Value = wsData.Cells(lngRow, cstrColData).Value
    End If
  Next lngRow
  
  Set wsTarget = Nothing
  Set wsData = Nothing
  Application.ScreenUpdating = True
End Sub

Ciao,
Holger

 

[ouvay]

Dim omzet As Worksheet: Set omzet = Workbooks.Item("Omzet").Sheets("Sheet1") Dim Maandafsluiting As Worksheet: Set Maandafsluiting = Workbooks.Item("Maandafsluiting").Sheets(1)

    Dim omzet As Worksheet: Set omzet = Workbooks.Item("Omzet.xlsm").Sheets("Sheet1")
    Dim Maandafsluiting As Worksheet: Set Maandafsluiting = Workbooks.Item("Maandafsluiting.xlsx").Sheets(1)

forgot to add the file extension in the code.. please change it on your end

 

[ASadStudent]

Give this a go

Option Base 1
Option Explicit

Sub ASadStudent_CopyPaste()
    Dim omzet As Worksheet: Set omzet = Workbooks.Item("Omzet").Sheets("Sheet1")
    Dim Maandafsluiting As Worksheet: Set Maandafsluiting = Workbooks.Item("Maandafsluiting").Sheets(1)
   
    Dim data As Variant, lr As Long, d As Object, key As String, rw As Long
  
    lr = omzet.Cells(Rows.Count, 1).End(3).Row
    data = omzet.Cells(1, 1).Resize(lr, 5).Value
   
    Set d = CreateObject("Scripting.Dictionary")
   
    For rw = LBound(data) To UBound(data)
        If data(rw, 5) <> 0 Then
            key = data(rw, 1)
            If Not d.exists(key) Then
                d(key) = data(rw, 5)
            End If
        End If
    Next rw
   
    lr = Maandafsluiting.Cells(Rows.Count, 1).End(3).Row
    data = Maandafsluiting.Cells(1, 1).Resize(lr, 7).Value
      
    For rw = LBound(data) To UBound(data)
        key = data(rw, 1)
        If d.exists(key) Then
            data(rw, 7) = d(key)
        End If
    Next rw
  
    Maandafsluiting.Cells(1, 7).Resize(UBound(data)).Value = Application.Index(data, 0, 7)
End Sub

Hope this works, if this doesn't I'm going to need specifics about your sheets and ranges
For example..

workbook : omzet
sheet name : "Sheet 1"
look up range : "Column A"
look up value : "Column E"

and so on ...
let me know how it goes

Thanks a lot.
This code worked and solved my problem.