VBA code to copy from one sheet to another based on two criteria

[Venus Lee]

Hello everyone,
First of all, thank you for taking your time by viewing my post. I have tried to find some old threads but can't seem to find a suitable solution.

Here's my situation:
I have 2 worksheets within the same workbooks.
Input sheet = "Ad-hoc Payment"
Output sheet = "Upload Template"

Basically, I will need user to input data in input sheet and I need to generate the "Upload Template" as output sheet.

I wish to create a VBA that can help to copy data from input sheet to output sheet.

Input sheet:

Output sheet:

 

[DanteAmor]

Hi and welcome to MrExcel!

I wish to create a VBA that can help to copy data from input sheet to output sheet.
"based on two criteria"

What are those 2 criteria?
Or just copy the unique values?

What data do you want to copy and where do you want to paste it?

NOTE XL2BB:
For the future, it would help greatly if you could give us the sample data in a form that we can copy to test with, rather that a picture.
MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in
Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

 

[Venus Lee]

Hi and welcome to MrExcel!


What are those 2 criteria?
Or just copy the unique values?

What data do you want to copy and where do you want to paste it?

NOTE XL2BB:
For the future, it would help greatly if you could give us the sample data in a form that we can copy to test with, rather that a picture.
MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in
Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

Hello @DanteAmor, thanks for replying.

2 criteria are employee ID and pay component.

For instance, I want the output sheet to copy data from input sheet based on column A (employee ID) and column C (pay component) and then copy the amount from column D into output sheet.

So, in my example, input sheet cell D6 will be copied into output sheet cell C2 and go on and on for other rows.

It can be done by using pivot table but each time I still need to some blank rows and columns and copy paste value in order to create the output sheet.

 

[DanteAmor]

Try this:

Sub CopyData()
  Dim sh2 As Worksheet
  Dim dic1 As Object, dic2 As Object
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, y As Long
  
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set sh2 = Sheets("Upload Template")
  
  With Sheets("Ad-hoc Payment")
    a = .Range("A6", .Range("D" & Rows.Count).End(3)).Value
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1) + 2)
  End With
  
  For i = 1 To UBound(a, 1)
    If Not dic1.exists(a(i, 1)) Then
      y = y + 1
      dic1(a(i, 1)) = y
    End If
    If Not dic2.exists(a(i, 3)) Then
      k = k + 1
      dic2(a(i, 3)) = k
    End If
    y = dic1(a(i, 1))
    k = dic2(a(i, 3))
    b(y, 1) = a(i, 1)
    b(y, 2) = a(i, 2)
    b(y, k + 2) = b(y, k + 2) + a(i, 4)
  Next
    
  With Sheets("Upload Template")
    .Cells.ClearContents
    .Range("A1:B1").Value = Array("Emp No", "Emp Name")
    .Range("C1").Resize(1, dic2.Count).Value = dic2.keys
    .Range("A2").Resize(dic1.Count, dic2.Count + 2).Value = b
  End With
End Sub

 

[Venus Lee]

Try this:

Sub CopyData()
  Dim sh2 As Worksheet
  Dim dic1 As Object, dic2 As Object
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, y As Long
 
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set sh2 = Sheets("Upload Template")
 
  With Sheets("Ad-hoc Payment")
    a = .Range("A6", .Range("D" & Rows.Count).End(3)).Value
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1) + 2)
  End With
 
  For i = 1 To UBound(a, 1)
    If Not dic1.exists(a(i, 1)) Then
      y = y + 1
      dic1(a(i, 1)) = y
    End If
    If Not dic2.exists(a(i, 3)) Then
      k = k + 1
      dic2(a(i, 3)) = k
    End If
    y = dic1(a(i, 1))
    k = dic2(a(i, 3))
    b(y, 1) = a(i, 1)
    b(y, 2) = a(i, 2)
    b(y, k + 2) = b(y, k + 2) + a(i, 4)
  Next
   
  With Sheets("Upload Template")
    .Cells.ClearContents
    .Range("A1:B1").Value = Array("Emp No", "Emp Name")
    .Range("C1").Resize(1, dic2.Count).Value = dic2.keys
    .Range("A2").Resize(dic1.Count, dic2.Count + 2).Value = b
  End With
End Sub

wow Dante! it works! thank you so so much!!
but, I still need some perfection if you could help. I still have a at F5 and i would like to preserve the ID in column A as 8 characters.
Below is my output mini sheet.

Test Allowance.xlsm
	A	B	C	D	E	F
1	Emp No	Emp Name	HEALTHCARE NUTRITION INCENTIVE	BONUS-NG S	ROADSHOW INCENTIVE_CARELINE
2	1212	APPLE	50
3	1314	ORANGE	175	6000
4	1211	PEAR			503
5						0
Upload Template

 

[DanteAmor]

i would like to preserve the ID in column A as 8 characters.

Change this line:

b(y, 1) = a(i, 1)

For this:

b(y, 1) = "'" & a(i, 1)