VBA code to re-arrange the data based on date and zone.

B

Balajibenz

Board Regular
Joined
Nov 18, 2020
Messages
80
Office Version
  1. 2013
Platform
  1. Windows
Hi All, Can some one help me with below requirement.

I have below data as input in source sheet.

KW2_Gagu Personal & Polen.xlsx
ABCDE
1NameDateFirmZoneTotal
2Adamcova, Milena1/11/2021Gagu PersonalOST1077
3Adamcova, Milena1/11/2021Gagu PersonalTRK100
4Adamcova, Milena1/13/2021Gagu PersonalTRK1135
5Adamcova, Milena1/12/2021Gagu PersonalOST1088
6Adamcova, Milena1/14/2021Gagu PersonalOST1348
7Adamcova, Milena1/15/2021Gagu PersonalOST1066
8Adamcova, Milena1/16/2021Gagu PersonalMSP1128
9Gaitur, Cristina1/11/2021Gagu PersonalOST331
10Gaitur, Cristina1/12/2021Gagu PersonalTRK71
11Gaitur, Cristina1/13/2021Gagu PersonalOST517
12Gaitur, Cristina1/14/2021Gagu PersonalOST57
13Gaitur, Cristina1/16/2021Gagu PersonalTRK148
14Zhydkova,Viktoriia1/11/2021Gagu PolenOST580
15Zhydkova,Viktoriia1/15/2021Gagu PolenOST707
Sheet4


Below is the output I am excpecting in "Output" sheet.

KW2_Gagu Personal & Polen.xlsx
ABCDEFGHIJKLMNO
11/11/20211/12/20211/13/20211/14/20211/15/20211/16/2021
2FirmNameZoneTotalZoneTotalZoneTotalZoneTotalZoneTotalZoneTotal
3Gagu PersonalAdamcova, MilenaOST1077OST1088TRK1135OST1348OST1066MSP1128
4Gagu PersonalAdamcova, MilenaTRK100
5Gagu PersonalGaitur, CristinaOST331TRK71OST517OST57TRK148
6Gagu PolenZhydkova,ViktoriiaOST580OST707
Sheet3


What I am looking for is to have the data arranged in horizantally based on Dates.

I have only shown the sample of data here while I have much more lines in original source.

There is might two possible scenarios.

1. A person might have worked in multiple zones in same day or worked in single zone.
2. A person migt have worked in single zone throughout the week or single but different zones throughout the week.

If a person worked in different zone each day but only worked in single zone(eg: Gaitur, Cristina in the source data) then that has to be in single line.

If a person worked in multiple zones in same day then additional line needs to be added for that line and respective total needs to be populated(eg:Adamcova, Milena). but lets take Adamcova, Milena worked in TRK on 1/13/2021 but as this is the only zone she has worked on that day that should be populated in first line(Row:3) but not the next (Row:4). Thank you in advance.
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
Try This at Same sheet:
VBA Code: 
Sub TransferData()
Dim d As Object, e As Object, f As Object, a As Variant, b As Variant, c As Variant
Dim g As Long, h As Long, i As Long, n As Long, Lr1 As Long, Lc As Long, j As Long
Dim k As Long, m As Long
Set d = CreateObject("Scripting.Dictionary")
Set e = CreateObject("Scripting.Dictionary")
Set f = CreateObject("Scripting.Dictionary")
Lr1 = Cells(Rows.Count, 3).End(xlUp).Row
'Set MyRange1 = Sheets("SHeet1").Range("A3:A" & Lr1)
a = Range("A2:A" & Lr1)
b = Range("B2:B" & Lr1)
c = Range("D2:D" & Lr1)
Lc = Cells(3, Columns.Count).End(xlToLeft).Column - 5

For i = 1 To UBound(a, 1)
   d(a(i, 1)) = 1
Next i
  Sheets("Sheet1").Range("G3").Resize(d.Count) = Application.Transpose(d.keys)
  Range("G3:G" & d.Count + 2).Sort key1:=Range("G3"), Order1:=xlAscending, Header:=xlNo
 
For i = 1 To UBound(b, 1)
   e(b(i, 1)) = 1
Next i
  Sheets("Sheet1").Range("J1").Resize(e.Count) = Application.Transpose(e.keys)
  Range("J1:J" & e.Count).Sort key1:=Range("J1"), Order1:=xlAscending, Header:=xlNo
  Sheets("Sheet1").Range("J1").Resize(, e.Count) = Application.Transpose(Range("J1:J" & e.Count).Value)
  Range("J2:J" & e.Count).ClearContents
  Lc = Cells(1, Columns.Count).End(xlToLeft).Column
  For j = Lc To 10 Step -1
Cells(2, j).Value = "Total"
Columns(j).Insert
Cells(1, j).Value = Cells(1, j + 1).Value
Cells(2, j).Value = "Zone"
Next j
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 3 To Lr1
If Range("G" & i).Value = Range("G" & i - 1).Value Then
Else

End If
For j = 10 To Lc Step 2
g = Application.WorksheetFunction.CountIfs(Range("A2:A" & Lr1), Range("G" & i), Range("B2:B" & Lr1), Cells(1, j))
If g > 1 And Range("G" & i).Value <> Range("G" & i - 1).Value Then
Range("G" & i + 1).Resize(g - 1).Insert Shift:=xlDown
Range("G" & i + 1 & ":G" & i + g - 1).Value = Range("G" & i).Value
End If
For n = 2 To Lr1
If Cells(n, 1).Value = Range("G" & i).Value And Cells(n, 2).Value = Cells(1, j).Value Then
m = Application.WorksheetFunction.CountIfs(Range("A2:A" & n), Range("G" & i), Range("B2:B" & n), Cells(1, j))
If m = Application.WorksheetFunction.CountIf(Range("G3:G" & i), Range("G" & i)) Then
h = n - 1
If h > 0 Then
GoTo Resum
End If
End If
End If
Next n
Resum:
  If Cells(i, 8).Value = "" Then
Cells(i, 8).Value = Application.WorksheetFunction.Index(Range("C2:C" & Lr1), h)
End If
Cells(i, j).Value = Application.WorksheetFunction.Index(Range("D2:D" & Lr1), h)
Cells(i, j + 1).Value = Application.WorksheetFunction.Index(Range("E2:E" & Lr1), h)
h = 0
Next j
  Next i
End Sub
 
Upvote 0
Solution
maabadi said:
Try This at Same sheet:
VBA Code: 
Sub TransferData()
Dim d As Object, e As Object, f As Object, a As Variant, b As Variant, c As Variant
Dim g As Long, h As Long, i As Long, n As Long, Lr1 As Long, Lc As Long, j As Long
Dim k As Long, m As Long
Set d = CreateObject("Scripting.Dictionary")
Set e = CreateObject("Scripting.Dictionary")
Set f = CreateObject("Scripting.Dictionary")
Lr1 = Cells(Rows.Count, 3).End(xlUp).Row
'Set MyRange1 = Sheets("SHeet1").Range("A3:A" & Lr1)
a = Range("A2:A" & Lr1)
b = Range("B2:B" & Lr1)
c = Range("D2:D" & Lr1)
Lc = Cells(3, Columns.Count).End(xlToLeft).Column - 5

For i = 1 To UBound(a, 1)
   d(a(i, 1)) = 1
Next i
  Sheets("Sheet1").Range("G3").Resize(d.Count) = Application.Transpose(d.keys)
  Range("G3:G" & d.Count + 2).Sort key1:=Range("G3"), Order1:=xlAscending, Header:=xlNo

For i = 1 To UBound(b, 1)
   e(b(i, 1)) = 1
Next i
  Sheets("Sheet1").Range("J1").Resize(e.Count) = Application.Transpose(e.keys)
  Range("J1:J" & e.Count).Sort key1:=Range("J1"), Order1:=xlAscending, Header:=xlNo
  Sheets("Sheet1").Range("J1").Resize(, e.Count) = Application.Transpose(Range("J1:J" & e.Count).Value)
  Range("J2:J" & e.Count).ClearContents
  Lc = Cells(1, Columns.Count).End(xlToLeft).Column
  For j = Lc To 10 Step -1
Cells(2, j).Value = "Total"
Columns(j).Insert
Cells(1, j).Value = Cells(1, j + 1).Value
Cells(2, j).Value = "Zone"
Next j
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 3 To Lr1
If Range("G" & i).Value = Range("G" & i - 1).Value Then
Else

End If
For j = 10 To Lc Step 2
g = Application.WorksheetFunction.CountIfs(Range("A2:A" & Lr1), Range("G" & i), Range("B2:B" & Lr1), Cells(1, j))
If g > 1 And Range("G" & i).Value <> Range("G" & i - 1).Value Then
Range("G" & i + 1).Resize(g - 1).Insert Shift:=xlDown
Range("G" & i + 1 & ":G" & i + g - 1).Value = Range("G" & i).Value
End If
For n = 2 To Lr1
If Cells(n, 1).Value = Range("G" & i).Value And Cells(n, 2).Value = Cells(1, j).Value Then
m = Application.WorksheetFunction.CountIfs(Range("A2:A" & n), Range("G" & i), Range("B2:B" & n), Cells(1, j))
If m = Application.WorksheetFunction.CountIf(Range("G3:G" & i), Range("G" & i)) Then
h = n - 1
If h > 0 Then
GoTo Resum
End If
End If
End If
Next n
Resum:
  If Cells(i, 8).Value = "" Then
Cells(i, 8).Value = Application.WorksheetFunction.Index(Range("C2:C" & Lr1), h)
End If
Cells(i, j).Value = Application.WorksheetFunction.Index(Range("D2:D" & Lr1), h)
Cells(i, j + 1).Value = Application.WorksheetFunction.Index(Range("E2:E" & Lr1), h)
h = 0
Next j
  Next i
End Sub
Click to expand...
Hi Mate, You are genius and that works perfectly :) my client is using german version of excel and macro it is running without any errors but zone and total values are not being populated. is there something you can help me with.
 
Upvote 0
If your words at Cells D1 & E1 THen
Change this:
VBA Code: 
Cells(2, j).Value = "Total"
Columns(j).Insert
Cells(1, j).Value = Cells(1, j + 1).Value
Cells(2, j).Value = "Zone"

TO
VBA Code: 
Cells(2, j).Value = Range("D1").Value
Columns(j).Insert
Cells(1, j).Value = Cells(1, j + 1).Value
Cells(2, j).Value = Range("E1").Value
 
Upvote 0
maabadi said:
If your words at Cells D1 & E1 THen
Change this:
VBA Code: 
Cells(2, j).Value = "Total"
Columns(j).Insert
Cells(1, j).Value = Cells(1, j + 1).Value
Cells(2, j).Value = "Zone"

TO
VBA Code: 
Cells(2, j).Value = Range("D1").Value
Columns(j).Insert
Cells(1, j).Value = Cells(1, j + 1).Value
Cells(2, j).Value = Range("E1").Value
Click to expand...
Hi Maabadi,

what i meant was code is running and headers(Date/Zone and Total) are reflecting but respective data under the headers are not reflecting in German version of excel. Firm and names are also populating.
 
Upvote 0
Sorry. I don't familiar with Local items works for second language at VBA,
Maybe others can help You.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Re-arranging and Sorting Data using a VBA Macro
2
Replies
10
Views
558
Akuini
Akuini
trishcollins
  • Solved
Excel vba set bold specific text of string into the cell in Pivot table.
Replies
2
Views
488
trishcollins
trishcollins
D
  • Question Question
If formula with date & VLOOKUP
Replies
1
Views
318
etaf
etaf
Sandeep Warrier
  • Question Question
Calculate No. of Working Days based on Shift Pattern
Replies
2
Views
150
Tetra201
Tetra201
G
  • Solved
VBA Userform Date Format
2
Replies
12
Views
303
Jack George
J

Forum statistics

Threads
1,224,818
Messages
6,181,151
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top