VBA to format survey data

[tparmbru22]

I need help creating VBA to format survey data from an excel output. Below are examples of the data and the final format that I'm looking to achieve.

The data in columns 1-3 will need to repeat as needed based on the information provided in columns 4-9.
Columns 4-6, the header is the "category" and the data is the "issue".
Columns 7-9, the "category" will all be "Expense" but the data needs to be combined into "issue".

Appreciate any help with this request.

Survey data

Date	ID	Name	Construction	IT	Marketing	Expense Part	Expense Qty	Expense Reason
01/12/22​	1234​	Joe Smith	Missing drywall		Missing sign kit	10001,Binders	1​	Missing
01/25/22​	5678​	Jane Doe		Missing monitor	Labels
02/02/22​	2468​	Mike Smith	Wiring	Pinpad broken		10007,Receipt tape	5​	Lost
02/15/22​	3692​	Linda Johnson			Labels	10004,Pens	20​	Missing

Final formatted data

Date	ID	Name	Category	Issue
01/12/22​	1234​	Joe Smith	Construction	Missing drywall
01/12/22​	1234​	Joe Smith	Marketing	Missing sign kit
01/12/22​	1234​	Joe Smith	Expense	10001,Binders - 1 - Missing
01/25/22​	5678​	Jane Doe	IT	Missing monitor
01/25/22​	5678​	Jane Doe	Marketing	Labels
02/02/22​	2468​	Mike Smith	Construction	Wiring
02/02/22​	2468​	Mike Smith	IT	Pinpad broken
02/02/22​	2468​	Mike Smith	Expense	10007,Receipt tap - 5 - Lost
02/15/22​	3692​	Linda Johnson	Marketing	Labels
02/15/22​	3692​	Linda Johnson	Expense	10004,Pens - 20 - Missing

 

[mumps]

Change the sheet names to suit your needs.

Sub FormatData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet, r As Long, c As Long, x As Long, y As Long, arr As Variant
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    desWS.Range("A1:E1") = Array("Date", "ID", "Name", "Category", "Issue")
    desWS.UsedRange.Offset(1).ClearContents
    With srcWS
        arr = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 9).Value
        For r = 2 To UBound(arr)
            x = WorksheetFunction.CountA(.Range("D" & r & ":F" & r))
            If WorksheetFunction.CountA(.Range("G" & r & ":I" & r)) > 0 Then y = 1
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(x + y).Value = (arr(r, 1))
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(x + y).Value = (arr(r, 2))
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(x + y).Value = (arr(r, 3))
                For c = 4 To 6
                    If arr(r, c) <> "" Then
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = (arr(1, c))
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = (arr(r, c))
                    End If
                Next c
                If y > 0 Then
                    .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = "Expense"
                    .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = Join(Application.Transpose(Application.Transpose(srcWS.Range("G" & r & ":I" & r).SpecialCells(xlCellTypeConstants).Value)), "-")
                End If
                y = 0
            End With
        Next r
    End With
    Application.ScreenUpdating = True
End Sub

 

[jdean5800]

Mumps,

Do you hire out to help with spreadsheets? If so I have a couple spreadsheets I have been working on that need some assistance that is beyond me. Let me know the best means of contacting you.

thank you,
Joe

 

[tparmbru22]

Change the sheet names to suit your needs.

Sub FormatData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet, r As Long, c As Long, x As Long, y As Long, arr As Variant
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    desWS.Range("A1:E1") = Array("Date", "ID", "Name", "Category", "Issue")
    desWS.UsedRange.Offset(1).ClearContents
    With srcWS
        arr = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 9).Value
        For r = 2 To UBound(arr)
            x = WorksheetFunction.CountA(.Range("D" & r & ":F" & r))
            If WorksheetFunction.CountA(.Range("G" & r & ":I" & r)) > 0 Then y = 1
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(x + y).Value = (arr(r, 1))
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(x + y).Value = (arr(r, 2))
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(x + y).Value = (arr(r, 3))
                For c = 4 To 6
                    If arr(r, c) <> "" Then
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = (arr(1, c))
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = (arr(r, c))
                    End If
                Next c
                If y > 0 Then
                    .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = "Expense"
                    .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = Join(Application.Transpose(Application.Transpose(srcWS.Range("G" & r & ":I" & r).SpecialCells(xlCellTypeConstants).Value)), "-")
                End If
                y = 0
            End With
        Next r
    End With
    Application.ScreenUpdating = True
End Sub

Thanks for the above VBA, it worked great.

I need to add some additional columns to the source data that will cause the VBA to change.

Columns 7-8, the header is "category" but also contains part of the "issue" and the data is also the "issue"
Columns 9-14, the "category" will all be "Expense" and the issue needs to be combined into "issue", there will be repeating column headers but with different data

Source data

Date

ID

Name

Construction

IT

Marketing

DSD - 1234 - Water

DSD - 2345 - Vending

Expense Part

Expense Qty

Expense Reason

Expense Part

Expense Qty

Expense Reason

01/12/22​

1234​

Joe Smith

Missing drywall

Missing sign kit

2​

10001,Binders

1​

Missing

10003,Paper

1​

Missing

01/25/22​

5678​

Jane Doe

Missing monitor

Labels

10​

02/02/22​

2468​

Mike Smith

Wiring

Pinpad broken

3​

5​

10007,Receipt tape

5​

Lost

10008,Outlets

5​

Lost

02/15/22​

3692​

Linda Johnson

Labels

10004,Pens

20​

Missing

10003,Paper

20​

Missing

Formatted data

Date	ID	Name	Category	Issue
01/12/22​	1234​	Joe Smith	Construction	Missing drywall
01/12/22​	1234​	Joe Smith	Marketing	Missing sign kit
01/12/22​	1234​	Joe Smith	DSD	1234 - Water - 2
01/12/22​	1234​	Joe Smith	Expense	10001,Binders - 1 - Missing
01/12/22​	1234​	Joe Smith	Expense	10003,Paper - 1 - Missing
01/25/22​	5678​	Jane Doe	IT	Missing monitor
01/25/22​	5678​	Jane Doe	Marketing	Labels
01/25/22​	5678​	Jane Doe	DSD	2345 - Vending - 10
02/02/22​	2468​	Mike Smith	Construction	Wiring
02/02/22​	2468​	Mike Smith	IT	Pinpad broken
02/02/22​	2468​	Mike Smith	DSD	1234 - Water - 3
02/02/22​	2468​	Mike Smith	DSD	2345 - Vending - 5
02/02/22​	2468​	Mike Smith	Expense	10007,Receipt tap - 5 - Lost
02/02/22​	2468​	Mike Smith	Expense	10008,Outlets - 5 - Lost
02/15/22​	3692​	Linda Johnson	Marketing	Labels
02/15/22​	3692​	Linda Johnson	Expense	10004,Pens - 20 - Missing
02/15/22​	3692​	Linda Johnson	Expense	10003,Paper - 20 - Missing

 

[mumps]

@jdean5800
Forum members agree to help on a volunteer basis. The Forum does have a consultation service for a fee if that is the route you want to take. This is the link: Consulting Services

 

[mumps]

Try:

Sub FormatData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet, r As Long, c As Long, x As Long, y As Long, z As Long, arr As Variant
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    desWS.UsedRange.ClearContents
    desWS.Range("A1:E1") = Array("Date", "ID", "Name", "Category", "Issue")
    With srcWS
        arr = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 14).Value
        For r = 2 To UBound(arr)
            x = WorksheetFunction.CountA(.Range("D" & r & ":H" & r))
            If WorksheetFunction.CountA(.Range("I" & r & ":K" & r)) > 0 Then y = 1
            If WorksheetFunction.CountA(.Range("L" & r & ":N" & r)) > 0 Then z = 1
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(x + y + z).Value = (arr(r, 1))
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(x + y + z).Value = (arr(r, 2))
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(x + y + z).Value = (arr(r, 3))
                For c = 4 To 6
                    If arr(r, c) <> "" Then
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = (arr(1, c))
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = (arr(r, c))
                    End If
                Next c
                For c = 7 To 8
                    If arr(r, c) <> "" Then
                        .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = "DSD"
                        .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = Mid(arr(1, c), 7, 9999) & " - " & arr(r, c)
                    End If
                Next c
                If y > 0 Then
                    .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = "Expense"
                    .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = Join(Application.Transpose(Application.Transpose(srcWS.Range("I" & r & ":K" & r).SpecialCells(xlCellTypeConstants).Value)), " - ")
                End If
                If z > 0 Then
                    .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = "Expense"
                    .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = Join(Application.Transpose(Application.Transpose(srcWS.Range("L" & r & ":N" & r).SpecialCells(xlCellTypeConstants).Value)), " - ")
                End If
                y = 0
                z = 0
            End With
        Next r
    End With
    Application.ScreenUpdating = True
End Sub