VBA to Check Duplicate Names and Align Data from Multiple Lines to Just 1 Line

[lamarh755]

I have a spreadsheet that is exported from Kronos for employee timekeeping. The report often lists the employees name (in Column A) more than once because there are only 2 punches per line. The first punch is the start punch, the next punch is the punch for lunch. The second line normally has the punch back from lunch (if the employee leaves the building), followed by the end of shift punch. There are times were there are more lines for the same employee based on if the employee arrived late, left early, etc. I am trying to create a macro that will do the following...

* Check the number of times the name appears in Column A, line by line and display the value in Column C. So if A3 has a name that appears for the first time, the value in C3 would be 1. If A4 has the same name, the value in C4 would be 2, so for and so on until the end of the sheet. For every new name or non match in Column A, the value in Column C would go back to 1.

* If the value is 1 in Column C, Copy the values showing in Columns E and F of that same row and paste the information in I and J.
* If the value is 2 in Column C, Copy the values showing in Columns E and F of that same row and paste the information in K and L of the same row that has the value of 1 in Column C.
* If the value is 3 in Column C, Copy the values showing in Columns E and F of that same row and paste the information in M and N of the same row that has the value of 1 in Column C.

I am trying to place all of the punches on the same line so that a lookup from another sheet captures all of the punches and puts them in order as well. I already have the macro for the other sheet.

Please see attached example.

 

[DanteAmor]

Try this

Sub AlignData()
  Dim a As Variant, b As Variant
  Dim dic As Object, i As Long, j As Long, k As Long
  '
  Set dic = CreateObject("Scripting.dictionary")
  a = Range("A3:G" & Range("A" & Rows.Count).End(3).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1))
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = Empty
      j = i
      k = 1
      b(j, k) = a(i, 6)
      b(j, k + 1) = a(i, 7)
      k = k + 2
    Else
      b(j, k) = a(i, 6)
      b(j, k + 1) = a(i, 7)
      k = k + 2
    End If
  Next
  Range("I3").Resize(UBound(a), k).Value = b
End Sub

 

[lamarh755]

The macro is copying/pasting F and G instead of E and F (as shown in example 1). I tried to read and understand the code so I could correct the issue. I changed the values for a(i,6) and a(i,7) to a(i,5) and a(i,6) and got it capture the value for E but the value in Column F is not showing up in Column L (as shown in example 2). Only thing that I can think of is that there should be a Dim L As Long, M As Long, etc., but I am not sure.

 

[DanteAmor]

Sorry for that, my mistake.
I put the updated code a little simplified.

Sub AlignData()
  Dim a As Variant, b As Variant
  Dim dic As Object, i As Long, j As Long, k As Long
  '
  Set dic = CreateObject("Scripting.dictionary")
  a = Range("A3:G" & Range("A" & Rows.Count).End(3).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1))
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = Empty
      j = i
      k = 1
    End If
    b(j, k) = a(i, 5)
    b(j, k + 1) = a(i, 6)
    k = k + 2
  Next
  Range("I3").Resize(UBound(a), k).Value = b
End Sub

 

[lamarh755]

It's still not populating data in Column L for some reason.

 

[DanteAmor]

works for me

varios 10abr2020.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	1	2	3	4	5	6	7
2	Employee	Date	No		In	Out	Shift		In	Out	In	Out	In	Out	In	Out	In	Out
3	all	04-sep			06:48	08:46			06:48	08:46
4	wil	05-sep			07:48	09:46			07:48	09:46	08:48	10:46
5	wil	06-sep			08:48	10:46
6	wil	07-sep
7	D	08-sep			01:00	01:00			01:00	01:00
8	wra	09-sep			02:00	02:00			02:00	02:00	03:00	03:00	04:00	04:00	05:00	05:00
9	wra	10-sep			03:00	03:00
10	wra	11-sep			04:00	04:00
11	wra	12-sep			05:00	05:00
Hoja3

Cell Formulas
Range	Formula
E7:F11,E4:F5	E4	=E3+"1:00"

_______________________________________________________________________________________
- Did you modify something of the macro?
- Do the data in columns A, E or F have spaces to the right or to the left within the cell?

 

[lamarh755]

I only copy and pasted the macro. Columns A,E or D do not have any spaces to the right or left. I opened a blank spreadsheet and keyed in data in a few cells and tested the macro and I still can't get data past column K.

 

[DanteAmor]

Try this

Sub AlignData()
  Dim a As Variant, b As Variant
  Dim dic As Object, i As Long, j As Long, k As Long
  '
  Set dic = CreateObject("Scripting.dictionary")
  a = Range("A3:F" & Range("A" & Rows.Count).End(3).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1))
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = Empty
      j = i
      k = 1
    End If
    b(j, k) = a(i, 5)
    b(j, k + 1) = a(i, 6)
    k = k + 2
  Next
  Range("I3").Resize(UBound(a), UBound(b, 2)).Value = b
End Sub

 

[lamarh755]

That worked!!! Thank you very much!!!

 

[DanteAmor]

Sorry for the errors in my code, I'm glad it already works for you. Thanks for the feedback.