VBA for Data w/ Repeating Headers

OvernightSilver

New Member
Joined
Aug 9, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hey everyone!

I'm a complete novice to VBA but reasonably comfortable with Excel, and I'm having some difficulty compiling the different scripts that I've borrowed from others to do what I'm trying to do! Basically, I have a team that gets a big sheet of raw data from a lab, and they painstakingly rearrange and shuffle it to be in batches of 10 with a repeating header row between them, to easily give out to their team members. It takes the lead a good 30 minutes every morning just to prep the sheet, and I'm looking to help her out. The amount of data that comes in will be variable (could be 50, could be 200, likely never more than 250 though).

I started by setting up two sheets in the same workbook, sheet1 (raw data) and sheet2(output). I was able to modify a column copy script I found that copied over the entirety of the columns (including the header), which is great! I was also able to get them into the order that the lead uses (we only use some of the columns from the raw data, so I was able to copy raw data column B to output column C, D to X, etc. and grab all the required columns)

So now I have the data able to copy the columns over via the script, but I'm not sure how to break it into batches of 10 with a repeating header until the end of the raw data. The only slight wrinkle is the leads use a slightly modified header row (ie, not exactly the titles that the raw data comes with) but I'm not sure how hard that would be to add, and they can adjust to what the raw data title says if that's easier. You can see the header they use on the second preview below:

So what I'm looking for is help creating this, ideally:
Upload raw data into the sheet1 area, run the macro, sheet2 will output the desired reorganized columns with a repeating header every 10 rows until the raw data has no more entries :)

Here is an example of the Raw data:
Data Entry New Maco.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACAD
1IDOWNER IDNAMEFIRST NAMELAST NAMEDOBGENDERPHONEADDRESSCITYSTATEZIPSomethingRaceEthnicitySomething2LAB DATAREGION 1OTHER REGIONLOCATIONIMPORT DATEpatient_typeSTATUSNOTESDATA KNOWNTHIRD REGIONNAME2POS OR NEGLAB DATA 2LAB DATE
2---90df8sd09f8sd098Batman JonesBatmanJones12/18/1993male32967683187692 Lectus St.Los AngelosCA12354---unknownunknown---CAS193849384398AK51GranteeRegion 1 HereLocation 1 here7/9/2021confirmedopenOut of StateyesRegion 1 hereBatman JonespositiveTest Lab 1238/2/2021
3---90df8sd09f8sd098Superman JacobsSupermanJacobs6/8/1924female6801039284248-2572 Dui Av.BostonMA45652---unknownunknown---CAS193849384398AK52GranteeRegion 2 hereLocation 1 here7/10/2021confirmedopen---yesRegion 2 hereSuperman JacobspositiveTest Lab 4568/7/2021
4---90df8sd09f8sd098Aquaman GreenAquamanGreen9/8/1929female1512971399906-9672 Ac StreetChicagoIL54654---unknownunknown---CAS193849384398AK53GranteeRegion 3 hereLocation 2 here7/11/2021confirmedopen---yesRegion 3 hereAquaman GreenpositiveTest Lab 7898/5/2021
5---90df8sd09f8sd098Deadpool SmithDeadpoolSmith4/12/1941male9753755116Ap #714-9619 Nunc St.SeattleWA13247---unknownunknown---CAS193849384398AK54GranteeRegion 4 hereLocation 3 here7/12/2021confirmedopen---yesRegion 1 hereDeadpool SmithpositiveTest Lab 11228/5/2021
6---90df8sd09f8sd098Jessica JonesJessicaJones3/3/1964female4355720381637-9857 Nunc AvePortlandOR87513---unknownunknown---CAS193849384398AK55GranteeRegion 1 HereLocation 1 here7/13/2021confirmedopen---yesRegion 2 hereJessica JonespositiveTest Lab 14558/5/2021
7---90df8sd09f8sd098Daredevil DavisDaredevilDavis1/11/1960female6806041615Ap #682-2158 In AveFlagstaffAZ56467---unknownunknown---CAS193849384398AK56GranteeRegion 2 hereLocation 1 here7/14/2021confirmedopen---yesRegion 3 hereDaredevil DavispositiveTest Lab 17888/5/2021
8---90df8sd09f8sd098Chris St JamesChrisSt James8/23/1953male6706363831658 Non, Av.Los AngelosCA13571---unknownunknown---CAS193849384398AK57GranteeRegion 3 hereLocation 2 here7/15/2021confirmedopen---yesRegion 1 hereChris St JamespositiveTest Lab 21218/5/2021
9---90df8sd09f8sd098Steve AustinSteveAustin6/30/1986female30478940123784 Leo, StreetBostonMA75123---unknownunknown---CAS193849384398AK58GranteeRegion 4 hereLocation 3 here7/16/2021confirmedopen---yesRegion 2 hereSteve AustinpositiveTest Lab 24548/6/2021
10---90df8sd09f8sd098Arnold EtchisonArnoldEtchison1/31/1953female3010103266794-2066 Lobortis Rd.ChicagoIL54713---unknownunknown---CAS193849384398AK59GranteeRegion 1 HereLocation 1 here7/17/2021confirmedopen---yesRegion 3 hereArnold EtchisonpositiveTest Lab 27878/5/2021
11---90df8sd09f8sd098Axel AsherAxel Asher8/1/1996female6940444487Ap #279-8415 Aliquam St.SeattleWA65721---unknownunknown---CAS193849384398AK60GranteeRegion 2 hereLocation 1 here7/18/2021confirmedopen---yesRegion 1 hereAxel AsherpositiveTest Lab 31208/6/2021
12---90df8sd09f8sd098Tex ThompsonTexThompson1/29/1984female5086965446265 Nisi RoadPortlandOR54621---unknownunknown---CAS193849384398AK61GranteeRegion 3 hereLocation 2 here7/19/2021confirmedopen---yesRegion 2 hereTex ThompsonpositiveTest Lab 34538/5/2021
13---90df8sd09f8sd098Tike AlicarTikeAlicar10/26/2010female33674710059860 Elit, Av.FlagstaffAZ16752---unknownunknown---CAS193849384398AK62GranteeRegion 4 hereLocation 3 here7/20/2021confirmedopenTest Note hereyesRegion 3 hereTike AlicarpositiveTest Lab 37868/5/2021
14---90df8sd09f8sd098Lonnie MachinLonnieMachin10/28/1978male31602298423097 Ac St.Los AngelosCA95423---unknownunknown---CAS193849384398AK63GranteeRegion 1 HereLocation 1 here7/21/2021confirmedopenYes yesRegion 1 hereLonnie MachinpositiveTest Lab 41198/4/2021
15---90df8sd09f8sd098Victor BorkowskiVictorBorkowski11/28/1924male2388719917462 Suspendisse RoadBostonMA11235---unknownunknown---CAS193849384398AK64GranteeRegion 2 hereLocation 1 here7/22/2021confirmedopen---yesRegion 2 hereVictor BorkowskipositiveTest Lab 44528/5/2021
16---90df8sd09f8sd098Toni monettiToniMonetti5/25/1999male6255119498Ap #794-673 In St.ChicagoIL13542---unknownunknown---CAS193849384398AK65GranteeRegion 3 hereLocation 2 here7/23/2021confirmedopen---yesRegion 3 hereToni monettipositiveTest Lab 47858/5/2021
17---90df8sd09f8sd098Jack KeatonJackKeaton1/30/1930female9019069746P.O. Box 240, 5959 Nibh St.SeattleWA66541---unknownunknown---CAS193849384398AK66GranteeRegion 4 hereLocation 3 here7/24/2021confirmedopen---yesRegion 1 hereJack KeatonpositiveTest Lab 51188/7/2021
18---90df8sd09f8sd098Marc SlaytonMarc Slayton9/18/1985male9881989763Ap #605-1650 Quis, Rd.PortlandOR75215---unknownunknown---CAS193849384398AK67GranteeRegion 1 HereLocation 1 here7/25/2021confirmedopen---yesRegion 2 hereMarc SlaytonpositiveTest Lab 54518/7/2021
19---90df8sd09f8sd098Sean CassidySeanCassidy3/1/2013male3913618709422-7148 In Rd.FlagstaffAZ77521---unknownunknown---CAS193849384398AK68GranteeRegion 2 hereLocation 1 here7/26/2021confirmedopen---yesRegion 3 hereSean CassidypositiveTest Lab 57848/5/2021
20---90df8sd09f8sd098Cassandra LaneCassandraLane9/25/1998female4363588416P.O. Box 125, 8429 Erat Av.Los AngelosCA33542---unknownunknown---CAS193849384398AK69GranteeRegion 3 hereLocation 2 here7/27/2021confirmedopenTest Note hereyesRegion 1 hereCassandra LanepositiveTest Lab 61178/5/2021
21
22
23
Sheet1


And here is an example of the output I'm hoping for!
Data Entry New Maco.xlsm
ABCDEFGHIJKLMNOPQRST
1ASSIGNFIRSTLASTDOBLAB DATATELGENDERRACEETHNICITYSTREETCITYZIPLABLAB DATEENTEREDCHECKEDNOTES
2BatmanJones12/18/1993CAS193849384398AK513296768318maleunknownunknown7692 Lectus St.Los Angelos12354Test Lab 1238/2/2021Out of State
3SupermanJacobs6/8/1924CAS193849384398AK526801039284femaleunknownunknown248-2572 Dui Av.Boston45652Test Lab 4568/7/2021---
4AquamanGreen9/8/1929CAS193849384398AK531512971399femaleunknownunknown906-9672 Ac StreetChicago54654Test Lab 7898/5/2021---
5DeadpoolSmith4/12/1941CAS193849384398AK549753755116maleunknownunknownAp #714-9619 Nunc St.Seattle13247Test Lab 11228/5/2021---
6JessicaJones3/3/1964CAS193849384398AK554355720381femaleunknownunknown637-9857 Nunc AvePortland87513Test Lab 14558/5/2021---
7DaredevilDavis1/11/1960CAS193849384398AK566806041615femaleunknownunknownAp #682-2158 In AveFlagstaff56467Test Lab 17888/5/2021---
8ChrisSt James8/23/1953CAS193849384398AK576706363831maleunknownunknown658 Non, Av.Los Angelos13571Test Lab 21218/5/2021---
9SteveAustin6/30/1986CAS193849384398AK583047894012femaleunknownunknown3784 Leo, StreetBoston75123Test Lab 24548/6/2021---
10ArnoldEtchison1/31/1953CAS193849384398AK593010103266femaleunknownunknown794-2066 Lobortis Rd.Chicago54713Test Lab 27878/5/2021---
11ASSIGNFIRSTLASTDOBLAB DATATELGENDERRACEETHNICITYSTREETCITYZIPLABLAB DATEENTEREDCHECKEDNOTES
12TexThompson1/29/1984CAS193849384398AK615086965446femaleunknownunknown265 Nisi RoadPortland54621Test Lab 34538/5/2021---
13TikeAlicar10/26/2010CAS193849384398AK623367471005femaleunknownunknown9860 Elit, Av.Flagstaff16752Test Lab 37868/5/2021---
14LonnieMachin10/28/1978CAS193849384398AK633160229842maleunknownunknown3097 Ac St.Los Angelos95423Test Lab 41198/4/2021Test Note here
15VictorBorkowski11/28/1924CAS193849384398AK642388719917maleunknownunknown462 Suspendisse RoadBoston11235Test Lab 44528/5/2021Yes
16ToniMonetti5/25/1999CAS193849384398AK656255119498maleunknownunknownAp #794-673 In St.Chicago13542Test Lab 47858/5/2021---
17JackKeaton1/30/1930CAS193849384398AK669019069746femaleunknownunknownP.O. Box 240, 5959 Nibh St.Seattle66541Test Lab 51188/7/2021---
18Marc Slayton9/18/1985CAS193849384398AK679881989763maleunknownunknownAp #605-1650 Quis, Rd.Portland75215Test Lab 54518/7/2021---
19SeanCassidy3/1/2013CAS193849384398AK683913618709maleunknownunknown422-7148 In Rd.Flagstaff77521Test Lab 57848/5/2021---
20CassandraLane9/25/1998CAS193849384398AK694363588416femaleunknownunknownP.O. Box 125, 8429 Erat Av.Los Angelos33542Test Lab 61178/5/2021---
21
22ASSIGNFIRSTLASTDOBLAB DATATELGENDERRACEETHNICITYSTREETCITYZIPLABLAB DATEENTEREDCHECKEDNOTES
23
24
25
26
Sheet2


I can share the script I was able to throw together to copy the columns as well, for what it's worth! I'm using this but I'm not beholden to anything, because admittedly I do not know much about VBA yet. I was able to make a sheet that mostly did what I wanted through formulas in Excel, but it was messy and using a bunch of cell or table references made it tough :(

Used this script, repeating changing the source and target as needed to move all the columns around that we needed:

Sub CopyColumnToWorkbook()
Dim sourceColumn As Range, targetColumn As Range

Set sourceColumn = Worksheets("Sheet1").Columns("D")
Set targetColumn = Worksheets("Sheet3").Columns("B")

End Sub


I was found some threads referencing repeating headers, which I THINK I could get to work with my column copy script here, but I was hoping to kinda use the header the team wants if possible, but definitely not a requirement because the only I can see it (with my very narrow VBA knowledge!) is to have it saved somewhere that it gets referenced to create the headers. Which could be possible I suppose, a hidden third sheet?
Thank you so much for any assistance, and I will endeavor to answer any questions that people have. I only started learning how to do VBA maybe.....a week ago, so to say I am new to this is an understatement, but I will try!
 

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
Welcome to the MrExcel board!

rearrange and shuffle it to be in batches of 10
Not too sure of this. Your sample output contains 9 names per group, not 10. But then you have omitted Axel Asher. Just an oversight I assume. In any case the code below should allow you to make the groups whatever size you want.

I have assumed that the sheet with the data to be processed is the active sheet when the code is run.

VBA Code:
Sub RearrangeData()
  Dim vRws As Variant, vCols As Variant, vData As Variant, vHdrs As Variant
  Dim r As Long, lr As Long
  
  Const GroupSize As Long = 10 '<- Edit if required
  
  vHdrs = Split("ASSIGN,FIRST,LAST,DOB,LAB DATA,TEL,GENDER,RACE,ETHNICITY,STREET,CITY,ZIP,LAB,LAB DATE,ENTERED,CHECKED,NOTES", ",")
  vRws = Evaluate("row(2:" & Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row & ")")
  vCols = Split("50 4 5 6 17 8 7 14 15 9 10 12 29 30 50 50 24")
  vData = Application.Index(Cells, vRws, vCols)
  Application.ScreenUpdating = False
  Sheets.Add After:=Sheets(Sheets.Count)
  With Sheets(Sheets.Count)
    .Range("A1").Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Union(.Columns("D"), .Columns("N")).NumberFormat = "m/d/yyyy"
    r = 1
    Do
      Rows(r).Insert
      With Cells(r, 1).Resize(, UBound(vHdrs) + 1)
        .Value = vHdrs
        .Interior.Color = vbGreen
      End With
      r = r + GroupSize + 1
    Loop Until IsEmpty(.Cells(r, 2).Value)
    .UsedRange.Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
Let us know if this copies the right data.
Change references, sheet names etc, where required.
If it copies the right data, will add to macro to insert rows with headers.
Code:
Sub Maybe()
Dim a, b(), headerArr, rawArr
Dim i As Long, j As Long, lr As Long
lr = Sheets("Sheet1").Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row    '<--- Change sheet name
a = Sheets("Sheet1").Range("A2").Resize(lr - 1, 31)    '<--- Change sheet name
headerArr = Array("ASSIGN", "FIRST", "LAST", "DOB", "LAB DATA", "TEL", "GENDER", "RACE", "ETHNICITY", "STREET", "CITY", "ZIP", "LAB", "LAB DATE", "ENTERED", "CHECKED", "NOTES")
rawArr = Array(1, 4, 5, 6, 17, 8, 7, 14, 15, 9, 10, 12, 29, 30, 31, 31, 24)
ReDim b(1 To UBound(a), 1 To 17)

    For i = 1 To UBound(a)
        For j = 1 To 17
            b(i, j) = a(i, rawArr(j))
        Next j
    Next i
    
    With Sheets("Sheet2")
        .Range("A1").Resize(, UBound(headerArr) + 1) = headerArr
        .Range("A2").Resize(UBound(b), UBound(b, 2)) = b
    End With
End Sub

I see Peter has you covered already.
 
Upvote 0
Since it was just about finished, this should do what you wanted.
You have to include the "Option Base 1" to avoid error messages.
Change references where required.
Code:
Option Explicit
Option Base 1

Sub Maybe()
Dim a, b(), headerArr, rawArr
Dim i As Long, j As Long, lr As Long, k As Long
lr = Sheets("Sheet1").Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row    '<--- Change sheet name
a = Sheets("Sheet1").Range("A2").Resize(lr - 1, 31)    '<--- Change sheet name
headerArr = Array("ASSIGN", "FIRST", "LAST", "DOB", "LAB DATA", "TEL", "GENDER", "RACE", "ETHNICITY", "STREET", "CITY", "ZIP", "LAB", "LAB DATE", "ENTERED", "CHECKED", "NOTES")
rawArr = Array(1, 4, 5, 6, 17, 8, 7, 14, 15, 9, 10, 12, 29, 30, 31, 31, 24)
ReDim b(1 To UBound(a), 1 To 17)

    For i = 1 To UBound(a)
        For j = 1 To 17
            b(i, j) = a(i, rawArr(j))
        Next j
    Next i
    
    With Sheets("Sheet2")
        .Range("A1").Resize(UBound(b), UBound(b, 2)) = b
            For k = 1 To lr Step 10
                .Rows(k).Insert
                    With .Cells(k, 1).Resize(, UBound(headerArr))
                        .Value = headerArr
                        .Interior.Color = vbGreen
                        .EntireRow.RowHeight = 30
                        .Font.Size = 14
                        .Font.Bold = True
                    End With
            Next k
    End With

End Sub

This should cut your time to a split second as well as Peter's suggestion I assume (have not tried it yet).
 
Upvote 0
Thank you guys both SO much for this! Using both of yours I was able to finesse and get it to a workable state to start with. I'm still going to do some modifications as I can figure it out (it's still very new to me) but I have this answer saved so I can come back and reference as I try to break this apart to understand it better.

Thank you both so, so much. Your experience and time is much appreciated in helping me.
 
Upvote 0
As Peter said, glad we could help but also thanks for letting us know.
Good luck
 
Upvote 0
@ Peter
Should these not have periods Peter?
Code:
.Rows(r).Insert
and
Code:
With .Cells(r, 1).Resize(, UBound(vHdrs) + 1)
 
Upvote 0
@ Peter
Should these not have periods Peter?
Ideally, yes, & I did not leave them out intentionally so I have re-posted the full (corrected) code below.
However, in practice it should not matter as the correct sheet would be the active sheet anyway - unless the user was stepping through the code and manually activated another sheet before those lines were reached.

Thanks for picking it up though. :)

VBA Code:
Sub RearrangeData()
  Dim vRws As Variant, vCols As Variant, vData As Variant, vHdrs As Variant
  Dim r As Long, lr As Long

  Const GroupSize As Long = 10 '<- Edit if required
  
  vHdrs = Split("ASSIGN,FIRST,LAST,DOB,LAB DATA,TEL,GENDER,RACE,ETHNICITY,STREET,CITY,ZIP,LAB,LAB DATE,ENTERED,CHECKED,NOTES", ",")
  vRws = Evaluate("row(2:" & Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row & ")")
  vCols = Split("50 4 5 6 17 8 7 14 15 9 10 12 29 30 50 50 24")
  vData = Application.Index(Cells, vRws, vCols)
  Application.ScreenUpdating = False
  Sheets.Add After:=Sheets(Sheets.Count)
  With Sheets(Sheets.Count)
    .Range("A1").Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Union(.Columns("D"), .Columns("N")).NumberFormat = "m/d/yyyy"
    r = 1
    Do
      .Rows(r).Insert
      With .Cells(r, 1).Resize(, UBound(vHdrs) + 1)
        .Value = vHdrs
        .Interior.Color = vbGreen
      End With
      r = r + GroupSize + 1
    Loop Until IsEmpty(.Cells(r, 2).Value)
    .UsedRange.Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
@ Peter.
I tried your code using an existing Sheet instead of adding a Sheet. That's why.

I changed my suggestion also because the code from Post #4 relied on Column AE to be empty.
This code does not.

Code:
Option Base 1
Sub Maybe()
Dim a, b(), headerArr, rawArr
Dim i As Long, j As Long, lr As Long, k As Long
lr = Sheets("Sheet1").Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row    '<--- Change sheet name
a = Sheets("Sheet1").Range("A2").Resize(lr - 1, 30)    '<--- Change sheet name

headerArr = Array("ASSIGN", "FIRST", "LAST", "DOB", "LAB DATA", "TEL", "GENDER", "RACE", "ETHNICITY", "STREET", "CITY", "ZIP", "LAB", "LAB DATE", "ENTERED", "CHECKED", "NOTES")
rawArr = Array(1, 4, 5, 6, 17, 8, 7, 14, 15, 9, 10, 12, 29, 30, 24)

Sheets("Sheet2").UsedRange.EntireRow.Delete Shift:=xlUp    '<---- Optional

ReDim b(1 To UBound(a), 1 To 15)

    For i = 1 To UBound(a)
        For j = 1 To 15

            b(i, j) = a(i, rawArr(j))
        Next j
    Next i
    
    With Sheets("Sheet2")
        .Range("A1").Resize(UBound(b), UBound(b, 2)) = b
        .Columns(15).Resize(, 2).Insert
            For k = 1 To lr Step 10
                .Rows(k).Insert
                    With .Cells(k, 1).Resize(, UBound(headerArr))
                        .Value = headerArr
                        .Interior.Color = vbGreen
                        .EntireRow.RowHeight = 30
                        .Font.Size = 14
                        .Font.Bold = True
                        .VerticalAlignment = xlCenter
                    End With
            Next k
        .UsedRange.Columns.AutoFit
    End With
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,836
Messages
6,174,923
Members
452,592
Latest member
Welshy1491

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