Macro Required or a Shortcut

[Abbas999]

Hi All members, I have around 2K records in a excel sheet with fields, Company, City, First name, Last name, Email, Then First name, Last Name, Email, Then First name Last name, Email, and so on.... Let me explain this. Each row contain a Company details and their workers first name, last name, email. Each company have at least one worker and up to 8 workers. Example Picture - It shows One Company one city but 6 workers working for them but data is in a single row.

<tbody>
</tbody>

Unknown
	A	B	C	D	E	F	G	H	I	J	K
255	Company Name	City/Prov	First 1	Last 1	Email 1	First 2	Last 2	Email 2	First 3	Last 3	Email 3
256	ISTITUTO CLINICO HUMANITAS	Rozzano	Simona	Camarda	simona.camarda@humanitas.it	Monica	Florianello	ufficio.stampa@humanitas.it	Marta	Galbiati	marta.galbiati@materdomini.it
Filtered

Here is what i want to organize them in excel sheet. In above picture it shows 1 Company with six workers in a single row. I want six rows for one company but only difference is worker name and email.

Unknown
	A	B	C	D	E
255	Company Name	City/Prov	First Name	Last name	Email
256	ISTITUTO CLINICO HUMANITAS	Rozzano	Simona	Camarda	simona.camarda@humanitas.it
257	ISTITUTO CLINICO HUMANITAS	Rozzano	Monica	Florianello	ufficio.stampa@humanitas.it
258	ISTITUTO CLINICO HUMANITAS	Rozzano	Marta	Galbiati	marta.galbiati@materdomini.it
259	ISTITUTO CLINICO HUMANITAS	Rozzano	Tatiana	Debelli	tatiana.debelli@gavazzeni.it
260	ISTITUTO CLINICO HUMANITAS	Rozzano	Laura	Capardoni	laura.capardoni@humanitas.it
261	ISTITUTO CLINICO HUMANITAS	Rozzano	Walter	Bruno	walter.bruno@humanitas.it
Filtered

I want to know if there is a way to do this in a better way? Other than first inserting rows then copying and pasting name emails.

Thank you in advance

 

[JoeMo]

This is untested - try it on a copy of your sheet.

Sub RearrangeData()
Dim R As Range, lC As Long, i As Long, Rws As Long, j As Long
Set R = Range("A255").CurrentRegion.Offset(1, 0).Resize(Range("A255").CurrentRegion.Rows.Count - 1)
lC = R.Columns.Count
Application.ScreenUpdating = False
For i = R.Rows.Count To 1 Step -1
       Rws = WorksheetFunction.CountA(Range(R.Rows(i).Cells(i, 3), R.Rows(i).Cells(i, lC))) / 3
       If Rws > 1 Then
              R.Rows(i).Offset(1, 0).Resize(Rws).EntireRow.Insert
              R.Rows(i).Cells(i, 1).Resize(Rws, 2).FillDown
              For j = 2 To Rws
                     Range(R.Rows(i).Offset(j - 1, 0).Cells(i, 3), _
                         R.Rows(i).Offset(j - 1, 0).Cells(i, 5)).Value = Range(R.Rows(i).Cells(i, j * Rws), _
                         R.Rows(i).Cells(i, j * Rws + 2)).Value
                         Range(R.Rows(i).Cells(i, j * Rws), R.Rows(i).Cells(i, j * Rws + 2)).ClearContents
              Next j
       End If
Next i
Application.ScreenUpdating = True
End Sub

 

[Abbas999]

This is untested - try it on a copy of your sheet.

Sub RearrangeData()
Dim R As Range, lC As Long, i As Long, Rws As Long, j As Long
Set R = Range("A255").CurrentRegion.Offset(1, 0).Resize(Range("A255").CurrentRegion.Rows.Count - 1)
lC = R.Columns.Count
Application.ScreenUpdating = False
For i = R.Rows.Count To 1 Step -1
       Rws = WorksheetFunction.CountA(Range(R.Rows(i).Cells(i, 3), R.Rows(i).Cells(i, lC))) / 3
       If Rws > 1 Then
              R.Rows(i).Offset(1, 0).Resize(Rws).EntireRow.Insert
              R.Rows(i).Cells(i, 1).Resize(Rws, 2).FillDown
              For j = 2 To Rws
                     Range(R.Rows(i).Offset(j - 1, 0).Cells(i, 3), _
                         R.Rows(i).Offset(j - 1, 0).Cells(i, 5)).Value = Range(R.Rows(i).Cells(i, j * Rws), _
                         R.Rows(i).Cells(i, j * Rws + 2)).Value
                         Range(R.Rows(i).Cells(i, j * Rws), R.Rows(i).Cells(i, j * Rws + 2)).ClearContents
              Next j
       End If
Next i
Application.ScreenUpdating = True
End Sub

@JoeMo Actually I used VBA few months ago and now I did'nt remeber how to execute this code in VBA. Could you please explain this?

 

[JackDanIce]

I just did the following:

Open a internet browsing window.
Went to Google.com
Typed into the search bar "Excel run a macro"
The top item is a box with full instructions on running a macro.

Did you try to search for the answer?

 

[Abbas999]

I just did the following:

Open a internet browsing window.
Went to Google.com
Typed into the search bar "Excel run a macro"
The top item is a box with full instructions on running a macro.

Did you try to search for the answer?

Yes Did it already but this code is not giving the required results.
It just doubles the Company name and City. Still looking for a solution

 

[Abbas999]

This is untested - try it on a copy of your sheet.

Sub RearrangeData()
Dim R As Range, lC As Long, i As Long, Rws As Long, j As Long
Set R = Range("A255").CurrentRegion.Offset(1, 0).Resize(Range("A255").CurrentRegion.Rows.Count - 1)
lC = R.Columns.Count
Application.ScreenUpdating = False
For i = R.Rows.Count To 1 Step -1
       Rws = WorksheetFunction.CountA(Range(R.Rows(i).Cells(i, 3), R.Rows(i).Cells(i, lC))) / 3
       If Rws > 1 Then
              R.Rows(i).Offset(1, 0).Resize(Rws).EntireRow.Insert
              R.Rows(i).Cells(i, 1).Resize(Rws, 2).FillDown
              For j = 2 To Rws
                     Range(R.Rows(i).Offset(j - 1, 0).Cells(i, 3), _
                         R.Rows(i).Offset(j - 1, 0).Cells(i, 5)).Value = Range(R.Rows(i).Cells(i, j * Rws), _
                         R.Rows(i).Cells(i, j * Rws + 2)).Value
                         Range(R.Rows(i).Cells(i, j * Rws), R.Rows(i).Cells(i, j * Rws + 2)).ClearContents
              Next j
       End If
Next i
Application.ScreenUpdating = True
End Sub

Not Giving the required results. Just doubles the first two coulmns.

 

[JoeMo]

Not Giving the required results. Just doubles the first two coulmns.

Is your data layout the same as you showed in your post?

 

[Abbas999]

Is your data layout the same as you showed in your post?

In the code i see it was starting Range "A255" but i deleted some rows in excel and the data i mentioned above was "A255" but now "A260" so i edit the code line
Before - Set R = Range("A255")
After - Set R = Range("A260")

and i got few things corrected but not 100%. When i scroll down in sheet i can see some names are still in a single row.

Maybe code needed more modification. Let me know if i did something wrong?

 

[JoeMo]

In the code i see it was starting Range "A255" but i deleted some rows in excel and the data i mentioned above was "A255" but now "A260" so i edit the code line
Before - Set R = Range("A255")
After - Set R = Range("A260")

and i got few things corrected but not 100%. When i scroll down in sheet i can see some names are still in a single row.

Maybe code needed more modification. Let me know if i did something wrong?

Are there any empty rows or columns between A260 and the end of your starting data?

 

[Abbas999]

Are there any empty rows or columns between A260 and the end of your starting data?

Do you mean a full empty row? or a row with at least one worker?