Copy blocks of cells into rows?-CodePudding

I have a spreadsheet that has 2 columns of data. Within those 2 columns, there are repeating blocks of information that comprise contact records. There is a consistent pattern to them.

This is the pattern:

I'm looking for a way to copy this data into a new Excel tab with a row per contact record: Name, Address, Unit, Mutual, Phone Number

Does anyone know a way to do this, by function or macro?

Thanks!

CodePudding user response：

This macro will do the trick. Just make sure that the sheet with your source data is active when you run it.

Sub copy_data()
  Dim source As Worksheet
  Dim dest As Worksheet
  Dim r As Long
  Dim row As Long
  Set source = ActiveSheet
  Set dest = ThisWorkbook.Worksheets.Add
  dest.Cells(1, 1).Value = "Name"
  dest.Cells(1, 2).Value = "Address"
  dest.Cells(1, 3).Value = "Unit"
  dest.Cells(1, 4).Value = "Mutual"
  dest.Cells(1, 5).Value = "Phone Number"
  r = 1
  row = 1
  Do Until source.Cells(r, 1).Value = ""
    row = row   1
    dest.Cells(row, 1).Value = source.Cells(r, 1).Value
    dest.Cells(row, 2).Value = source.Cells(r   1, 1).Value
    dest.Cells(row, 3).Value = source.Cells(r   1, 2).Value
    dest.Cells(row, 4).Value = source.Cells(r   2, 1).Value
    dest.Cells(row, 5).Value = source.Cells(r   2, 2).Value
    r = r   3
  Loop
  
End Sub