Excel VBA: Double-sided Name Badges

Thank you in advance for reading my question.😀

I'm looking for a way to print the exact information on both sides of name badges.

I have a data base in excel with three columns (Name | Last Name | Company). On other hand, i have a sheet in word that has two rows of three columns for a total of six badges per sheet.

I have seen that if i duplicated the rows in batches of six and swapped rows like: first with third, second stays in the same position, third with first, fourth with sixth, fifth stays in the same position and sixth with fourth for each of the duplicated batches, i would have a mirrored set of merge records ready for duplex printing.

This is an example of how the information should look assuming I only have the first 6 cells as the base information. The same information should be duplicated every 6 cells and always organized as I show in the table. (3 - 2 - 1 - 6 - 5 - 4)

I've seen this code that can serve as a basis to demonstrate that every 6 cells the information repeats, but the order here is given by evens and odds, and it doesnt order rows as i need. Thank you very much.

Sub mcrMakeDuplexData()
    Dim lBadgeRows As Long, lBadgeCols As Long, lBadgeOffSet As Long
    Dim i As Long, j As Long, lrw As Long, lcl As Long
    lBadgeRows = 3
    lBadgeCols = 2
    lBadgeOffSet = lBadgeRows * lBadgeCols
    lcl = Cells(1, Columns.Count).End(xlToLeft).Column
    lrw = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To lBadgeOffSet - ((lrw - 1) Mod lBadgeOffSet)
        For j = 1 To lcl
            Cells(lrw + i, j) = Chr(160)
        Next j
    Next i
    lrw = Cells(Rows.Count, 1).End(xlUp).Row
    For i = lrw To lBadgeOffSet Step -lBadgeOffSet
        Cells(i + 1, 1).Resize(lBadgeOffSet, 1).EntireRow.Insert
        Cells(i + 1, 1).Resize(lBadgeOffSet, lcl).Formula = _
          "=OFFSET(" & Cells(i + 1, 1).Address(0, 0) & _
            ",ISODD(ROWS($1:1))-" & lBadgeOffSet & "-ISEVEN(ROWS($1:1)),)"
        Cells(i + 1, 1).Resize(lBadgeOffSet, lcl) = _
            Cells(i + 1, 1).Resize(lBadgeOffSet, lcl).Value
    Next i
End Sub

Nat

I hope for assistance from those who are more familiar with the VBA language to program what I need and can explain to me how to do it

• I am not sure about the specific structure of your Word document. More code would be required to populate a table in Word based on the data in Excel workbook.

• Below code transforms data in Excel.

Option Explicit

Sub Demo()
    Dim iRow As Long, j As Long, iCol As Long, iIndex As Long, iRow2 As Long
    Dim arrData, rngData As Range
    Dim RowCnt As Long, ColCnt As Long
    Dim arrRes, sItem As String
    ' Load data
    arrData = ActiveSheet.Range("A1").CurrentRegion.Value
    ' Get size of data
    RowCnt = UBound(arrData)
    ColCnt = UBound(arrData, 2)
    ReDim arrRes(1 To Round(RowCnt / 6 + 0.5) * 12, 1 To ColCnt)
    iIndex = 0
    ' Loop through data, 6 rows as a group
    For iRow = LBound(arrData) To RowCnt Step 6
        ' Load the first part in order
        For j = 0 To 5
            iIndex = iIndex + 1
            For iCol = 1 To ColCnt
                If iRow + j > RowCnt Then
                    sItem = ""
                Else
                    sItem = arrData(iRow + j, iCol)
                End If
                arrRes(iIndex, iCol) = sItem
            Next iCol
        Next j
        ' Load the 2nd part in reverse order
        For iRow2 = 2 To 5 Step 3
            For j = iRow2 To iRow2 - 2 Step -1
                iIndex = iIndex + 1
                For iCol = 1 To ColCnt
                    If iRow + j > RowCnt Then
                        sItem = ""
                    Else
                        sItem = arrData(iRow + j, iCol)
                    End If
                    arrRes(iIndex, iCol) = sItem
                Next iCol
            Next
        Next iRow2
    Next iRow
    ' Write data to a new sheet
    Sheets.Add
    ActiveSheet.Range("A1").Resize(iIndex, ColCnt).Value = arrRes
End Sub