This is my first post, but I have an excel workbook with multiple tabs formatted like this:
I'm learning vba but don't know the excel functions well enough yet to loop through the rows and copy the data reformatted to a new sheet into this format:
Specifically I think i need to
- Initialize the range of worksheets
loop through them
store column headers for b through G into a variable so when the x is found it can be concatenated or copied over
handle the blank spaces so that the last value is used for each one
Any help appreciated. Thanks!
The following will do what you expect:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
Dim wsResult As Worksheet: Set wsResult = Sheets("Sheet2")
LastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
'get the last row with data on Column J
For i = 2 To LastRow
NextRow = wsResult.Cells(wsResult.Rows.Count, "D").End(xlUp).Row + 1
ws.Range("H" & i & ":J" & i).Copy Destination:=wsResult.Range("D" & NextRow)
wsResult.Range("A" & NextRow).Value = "Title"
If ws.Cells(i, 1) <> "" Then 'if GroupID is not empty
wsResult.Range("B" & NextRow).Value = ws.Cells(i, 1) 'grab that GroupID
Else
x = i
Do While Trim(ws.Cells(x, 1)) = ""
x = x - 1
Group = ws.Cells(x, 1) 'get the GroupID of the Row above
Loop
wsResult.Range("B" & NextRow).Value = Group
End If
For y = 2 To 7
If ws.Cells(i, y) <> "" Then
Level = ws.Cells(1, y).Value
Exit For
End If
Next y
wsResult.Cells(NextRow, 3) = Level
Next i
End Sub
Try this:
Sub BuildTable()
Dim data(), i As Integer, j As Integer
data = Worksheets("Sheet1").Range("A2:J5").Value
For i = 1 To UBound(data)
With Worksheets("Sheet2")
.Range("A" & i) = "Title"
.Range("D" & i) = data(i, 8)
.Range("E" & i) = data(i, 9)
.Range("F" & i) = data(i, 10)
If i > 1 Then
.Range("B" & i) = IIf(data(i, 1) <> "", data(i, 1), .Range("B" & i - 1))
Else
.Range("B" & i) = data(i, 1)
End If
For j = 2 To 7
If data(i, j) = "x" Then
.Range("C" & i) = "Level" & j - 1
End If
Next j
End With
Next i
End Sub
You can use Power Query Excel 2010+ you can download and activate easily or by default in 2016 version. There you can transform your data and put it as a table or a pivot table:
Related
I´m pretty new to VBA and since it´s making my job so much easier I try to write some codes from time to time and everything works fine except for this one, I already tried with the Screen Updating and the Status Bar method but it´s still very slow. Any ideas on how it coul be improved? Thnak you
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
i = 1
Do Until i > LastRow
If Range("B" & i) = Range(B & i + 1) Then
Range("L" & i) = Range("L" & i) + Range("L" & i + 1)
Range("M" & i) = Range("M" & i) + Range("M" & i + 1)
Range("N" & i) = Range("N" & i) + Range("N" & i + 1)
Range("O" & i) = Range("O" & i) + Range("O" & i + 1)
Range("P" & i) = Range("P" & i) + Range("P" & i + 1)
Range("Q" & i) = Range("Q" & i) + Range("Q" & i + 1)
Range("A" & i + 1).EntireRow.Delete
LastRow = LastRow - 1
Else
i = i + 1
End If
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
This does what your code does; i tested with 1k rows of data and it was faster then your code. (Updated with ja72's input)
Dim i As Long
Dim LastRow As Long
If Range("B1") = Range("B2") Then
Rows(1).Copy
Rows(1).Insert Shift:=xlDown
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(1, 12).Formula = "=SUM(L2:L" & LastRow & ")"
Cells(1, 12).Resize(, 5).FillRight
End If
Range("L1").Resize(1,10).Value = Range("L1").Resize(1,10).Value
Rows(2 & ":" & Rows.Count).Delete
The code below first addresses the issue of string math for the range picking. Instead of .Range("A" & i) it best to use .Offset() or .Cells() instead. Additionally it makes it explicit that we are dealing with values and not ranges when the math takes place. It is recommended to always type .Value where it is implied.
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim r As Range, g As Range
' Set the start of the optimization loop
Set r = Range("B1")
' While still inside the data
Do While r.Row <= LastRow
' Check this value with value of next row
If r.Value = r.Offset(1, 0).Value Then
Set g = r.Offset(0, 10) ' Pick column "L" of same row as r
Go from "L" to "Q"
For i = 1 To 6
'Add values one by one with row below
g.Offset(0, i - 1).Value = _
g.Offset(0, i - 1).Value + g.Offset(1, i - 1).Value
Next i
r.Offset(1, 0).EntireRow.Delete
LastRow = LastRow - 1
End If
' Move to next row
Set r = r.Offset(1, 0)
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
Depending on the total amount of data, it will be way faster to load all the data into memory and process it with VBA arrays only to be returned back in the end to the worksheet.
The following code should be orders of magnitude faster.
Sub DW2()
Dim i As Long, j As Long, i_out As Long, i_next As Long
Dim LastRow As Long, ValCol As Long, LastCol As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
ValCol = Cells(, "L").Column
LastCol = Cells(, "Q").Column
Dim r_data As Range
' Reference all the data (filled rows, and 17 columns "A:Q")
Set r_data = Range("A1").Resize(LastRow, LastCol)
' x is input data, y as output data
Dim x() As Variant, y() As Variant
' Copy all the table cells into memory
x = r_data.Value
' Create an empty array at least the same size
ReDim y(1 To LastRow, 1 To LastCol)
' i_out is index for output
i_out = 1
' i is index for input
For i = 1 To LastRow
' Debug.Print "Row"; i, "into Row:"; i_out
'Copy all values first from current row
For j = 1 To LastCol
y(i_out, j) = x(i, j)
Next j
' Index i_next peeks at the next row
i_next = i + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
' Check with value match on 2nd column "B"
Do While x(i, 2) = x(i_next, 2)
'Add up values in columns 11 through 17
For j = ValCol To LastCol
y(i_out, j) = y(i_out, j) + x(i_next, j)
Next j
' Peek at subsequent rows also
i_next = i_next + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
Loop
' Advance i if rows were skipped
i = i_next - 1
' Advance i_out
i_out = i_out + 1
Next i
' Clear all table cells
r_data.ClearContents
' Overwrite with the optimized values
r_data.Resize(i_out - 1, LastCol).Value = y
End Sub
Edit: Now tested for robustness when matching rows exist in the end of the data
I have an array of data, a screenshot of it will be linked at the bottom of this text. Row and column references are to the screenshot.
I am trying to write a macro that will output all the dates that occur within the dynamic range (Column H). And then in column I I want the column header # row i.e I4.
But if there is more than 1 count at the date, I would like the second school to output into column J. As it would for the date 26/03/18, looking like this:
h5 = 26/03/18 , i5(Event1) = Task 2 # 1, j5(Event2) = task 2 # 4
I have tried many ways today and would like some assistance.
Screenshot: https://ibb.co/cmiGSc
My Code thus far(For the more complex sheet):
Sub Events()
'How many schools there are
Dim sh As Worksheet
' This needs to change for each sheets
Set sh = ThisWorkbook.Sheets("Easter 18")
Dim k As Long
k = sh.Range("A3").End(xlDown).Row 'Counts up from bottow - Number of schools attained
Ro = Range("M52").value = k - 2 'Elimiates the two top rows as headers
'Now I need to search the Range of dates
Dim TaskDates As Range
Dim StartCell As Range 'First part of Array
Dim EndCell As Range 'End of Array
Set EndCell = Range("J" & 2 + k) 'maybe 2 or 3
Set StartCell = Range("G3")
Set TaskDates = Range(StartCell, EndCell) 'Dynamic Range
'Within the range of data print out the most left row header (school name) - and task with # in the middle - ascending
' If Column has date (true) create a table with Date (col 1), Event (col 2), Event 2 (Col3) etc etc
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant
varray = TaskDates.value
'Generate unique list and count
For Each element In varray
If dict.exists(element) Then
dict.item(element) = dict.item(element) + 1
Else
dict.Add element, 1
End If
Next
'Paste report somewhere -
'First line ouptuts the dates occured
sh.Range("M55").Resize(dict.Count).value = 'Was working now saying syntax error for this line.
WorksheetFunction.Transpose (dict.keys)
' The count works if cell format is correct
CDates = sh.Range("N55").Resize(dict.Count, 1).value = _
WorksheetFunction.Transpose(dict.items)
End Sub
Please feel free to redesign it if you see fit.
you can go this way
Option Explicit
Sub Tasks()
Dim cell As Range, f As Range
With Worksheets("schools") 'change "schools" to your actual sheet name
For Each cell In .Range("C4:F" & .Cells(.Rows.Count, "B").End(xlUp).Row) 'reference its column C:F from row 4 down to column B last not empty cell
If IsDate(cell.value) Then 'if current cell value is a valid date
Set f = .Range("H3", .Cells(.Rows.Count, "H").End(xlUp)).Find(what:=cell.value, lookat:=xlWhole, LookIn:=xlValues) 'try finding the date in column H
If f Is Nothing Then Set f = .Cells(.Rows.Count, "H").End(xlUp).Offset(1) 'if date not already in column H then get its first empty cell after last not empty one
f.value = cell.value 'write the date (this is sometimes not necessary, but not to "ruin" the code)
.Cells(f.Row, .Columns.Count).End(xlToLeft).Offset(, 1).value = .Cells(3, cell.Column).value & " #" & .Cells(cell.Row, 2).value ' write the record in the first not empty cell in the "date" row
End If
Next
End With
End Sub
Took a shot at this. Just a couple nested loops testing against the dates, making sure that the date found isn't already listed under the date column. As I stated before, you never said what to do if more than 3 dates are found, so I had to add a fourth event column and assume that that's the max. Anything more than 4 dates won't be recorded anywhere, FYI.
Sub MoveDates()
Dim i As Long, j As Long, sht As Worksheet, lastrow As Long, lastrow2 As Long, refrow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row + 1
For i = 4 To lastrow
For j = 3 To 6
If Cells(i, j).Value <> "" And Cells(i, j).Value <> "n/a" Then
If Not Application.WorksheetFunction.CountIf(Range("H4:H" & lastrow), Cells(i, j)) > 0 Then
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row + 1
Range("H" & lastrow2).Value = Cells(i, j).Value
If Range("I" & lastrow2).Value = "" Then
Range("I" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("J" & lastrow2).Value = "" Then
Range("J" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("K" & lastrow2).Value = "" Then
Range("K" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("L" & lastrow2).Value = "" Then
Range("L" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
End If
Else
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row
For k = 4 To lastrow2
If Range("H" & k).Value = Cells(i, j).Value Then
refrow = k
Exit For
End If
Next k
If Range("I" & refrow).Value = "" Then
Range("I" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("J" & refrow).Value = "" Then
Range("J" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("K" & refrow).Value = "" Then
Range("K" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("L" & refrow).Value = "" Then
Range("L" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
End If
End If
End If
Next j
Next i
End Sub
I am trying to copy from Sheet1, specific rows when on that row a specific cell has status "DONE" selected to say, and a second criteria after "DONE" is to check if on the same row, another cell has also a specific value. After that, copy the rows found each on specific sheet, checking destination if duplicates are found.
I have managed until now to copy from Sheet1 to the other based on the 2 criteria (old school with IF, I tried with autofilter but I didn't manage to do it) but I am having a hard time preventing duplicates to be copied to the other sheets.
I tried everything, value checking based on first sheet with Range, writing a macro for each sheet so it prevents duplicates, nothing worked and i am stuck on this.
Another problem with below code is that after hitting Update button multiple times, it doesn't duplicate all found rows, but only the first one found, and also inserts some empty rows in between and I don't understand the reason for that.
Here is the code:
Private Sub CommandButton1_Click()
Dim LastRow As Long
Dim i As Long, j As Long, k As Long, j1 As Long, k1 As Long, j_last As Long,
k_last As Long
Dim a As Long, b As Long
Dim ActiveCell As String
With Worksheets("PDI details")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Worksheets("Demo ATMC")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 2
End With
With Worksheets("Demo ATMC Courtesy")
k = .Cells(.Rows.Count, "A").End(xlUp).Row + 2
End With
With Worksheets("Demo SHJ")
j1 = .Cells(.Rows.Count, "A").End(xlUp).Row
k1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Worksheets("Demo AD")
a = .Cells(.Rows.Count, "A").End(xlUp).Row
b = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox (j)
For i = 5 To LastRow
With Worksheets("PDI details")
If .Cells(i, 20).Value <> "" Then
If .Cells(i, 20).Value = "DONE" Then
If .Cells(i, 11).Value = "ATMC DEMO" Then
If Not .Cells(i, 7) = Worksheets("Demo ATMC").Range("D4") Then
Worksheets("Demo ATMC").Range("A" & j) = Worksheets("PDI details").Range("A" & i).Value
Worksheets("Demo ATMC").Range("B" & j) = Worksheets("PDI details").Range("E" & i).Value
Worksheets("Demo ATMC").Range("C" & j) = Worksheets("PDI details").Range("F" & i).Value
Worksheets("Demo ATMC").Range("D" & j) = Worksheets("PDI details").Range("G" & i).Value
Worksheets("Demo ATMC").Range("F" & j) = Worksheets("PDI details").Range("H" & i).Value
Worksheets("Demo ATMC").Range("G" & j) = Worksheets("PDI details").Range("I" & i).Value
End If
End If
If .Cells(i, 11).Value = "ATMC COURTESY" Then
If Not .Cells(i, 7) = Worksheets("Demo ATMC Courtesy").Range("D4")
Then
Worksheets("Demo ATMC Courtesy").Range("A" & k) = Worksheets("PDI details").Range("A" & i).Value
Worksheets("Demo ATMC Courtesy").Range("B" & k) = Worksheets("PDI details").Range("E" & i).Value
Worksheets("Demo ATMC Courtesy").Range("C" & k) = Worksheets("PDI details").Range("F" & i).Value
Worksheets("Demo ATMC Courtesy").Range("D" & k) = Worksheets("PDI details").Range("G" & i).Value
Worksheets("Demo ATMC Courtesy").Range("F" & k) = Worksheets("PDI details").Range("H" & i).Value
Worksheets("Demo ATMC Courtesy").Range("G" & k) = Worksheets("PDI details").Range("I" & i).Value
k = k + 1
End If
End If
End If
End If
End With
Next i
End Sub
I couldn't test the code suggested below but I believe that it does what you wish it to do.
Option Explicit
Private Sub CommandButton1_Click()
' 23 Dec 2017
Dim WsPdi As Worksheet
Dim WsAtmc As Worksheet, WsCourtesy As Worksheet
Dim R As Long, Rl As Long ' row / lastrow "PDI details"
Set WsPdi = Worksheets("PDI Detail")
Set WsAtmc = Worksheets("Demo ATMC")
Set WsCourtesy = Worksheets("Demo ATMC Courtesy")
Application.ScreenUpdating = False
With WsPdi
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 5 To Rl
If .Cells(R, 20).Value = "DONE" Then
Select Case .Cells(R, 11).Value
Case "ATMC DEMO"
TransferData WsPdi, WsAtmc, R
Case "ATMC COURTESY"
TransferData WsPdi, WsCourtesy, R
End Select
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Private Sub TransferData(WsSource As Worksheet, _
WsDest As Worksheet, _
R As Long)
' 23 Dec 2017
Dim Csource() As String
Dim Rn As Long ' next empty row in WsDest
Dim C As Long
Csource = Split(",A,E,F,G,,H,R", ",")
With WsDest
If WsSource.Cells(R, 7).Value <> .Cells(4, "D").Value Then
Rn = .Cells(.LastRow, "A").End(xlUp).Row + 1
For C = 1 To 7 ' columns A to G
If C <> 5 Then
.Cells(Rn, C).Value = WsSource.Cells(R, Csource(C)).Value
End If
Next C
End If
End With
End Sub
Can anybody please help me figure out my problem?
I have this code that I would like to move to the next column if the condition is not met.I'm stuck and don't know where to proceed.
Dim lrow3, lrow1 as long
dim dDate as Date
dim yrNum, j as Integer
dDate = Format(Now(),"mm/dd/yyyy")
lrow3 = ActiveSheet.Cells(Rows.count, 2).End(xlUp).Row
lrow1 = Sheets("Sample").Cells(Rows.count, 2).End(xlUp).Row
for j = 2 to lrow1
For yrNum = 1 To 100
If DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) >= DateValue(dDate) And _
DateValue(Format(Range("R" & j).Value, "mm/dd/yyyy")) <= DateValue(dDate) Then
ActiveSheet.Range("D" & lrow3 + 1).Value = Range("T" & j).Value
ActiveSheet.Range("E" & lrow3 + 1).Value = Range("U" & j).Value
Exit For
Else
Range("Q" & j) = ActiveCell
Range("Q" & j) = ActiveCell.Offset(0, 9)
'after executing this is I have to set this offsetted cell to be the active one
'on which i will be referring in the next loop
End If
Next yrNum
next j
In the snippet, if the value in Q & j does not met the requirements, then i have to check the 9th letter after Q which is Z and so on.
By the way what I'm comparing on this are date values in the cell.
A few observations
dDate = Format(Now(),"mm/dd/yyyy") is the same as dDate = Date
DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) is the same asDateValue(Range("Q" & j).Value)`
You are starting in column Q and if the conditions are not meet you move over 9 columns and check again. You do this 100 times. The final column is column 917(column letter code AIG)
Sub RefactoredCode()
Dim lrow3, lrow1 As Long
Dim DateRange As Range
Dim wsSample As Worksheet
Dim yrNum, j As Integer, iOffset As Integer
Set wsSample = Worksheets("Sample")
lrow3 = Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = wsSample.Cells(Rows.Count, 2).End(xlUp).Row
For j = 2 To lrow1
For yrNum = 1 To 100
iOffset = (yrNum * 9) - 9
Set DateRange = wsSample.Cells(j, "Q").Offset(0, iOffset)
If DateValue(DateRange.Value) >= Date And _
DateValue(DateRange.Offset(0, 1).Value) <= Date Then
lrow3 = lrow3 + 1
Range("D" & lrow3).Value = wsSample.Cells(j, "T").Offset(0, iOffset).Value
Range("E" & lrow3).Value = wsSample.Cells(j, "U").Offset(0, iOffset).Value
Exit For
End If
Next yrNum
Next j
End Sub
I am trying to create a macro to copy rows starting from A7 from different sheets to a "Data" sheet. The Rows in each sheet vary. It is just copying Row 7 in each sheet. Here's my code:
Sub Button1_Click()
Worksheets("Data").Cells.ClearContents
Dim x As Integer
Dim y As Integer
Dim ws1 As Worksheet
Dim First As Integer
Dim Last As Integer
Dim i As Integer
Set ws1 = Worksheets("Data")
First = Worksheets("Data").Index
Last = Worksheets("Summary").Index
ws1.Range("A" & 1).Value = "Date"
ws1.Range("B" & 1).Value = "Equipment"
ws1.Range("C" & 1).Value = "Type"
ws1.Range("D" & 1).Value = "Qty / Hrs"
ws1.Range("E" & 1).Value = "Rate"
ws1.Range("F" & 1).Value = "Cost"
For i = (First + 1) To (Last - 1)
With Sheets(i)
MaxrOw = Cells(Rows.Count, "A").End(xlUp).Row
x = 7
Do Until .Range("A" & x).Value = ""
If Not .Range("I" & x).Value = "" Then
ws1.Range("A" & MaxrOw + 1).Value = .Range("G" & 2).Value
ws1.Range("B" & MaxrOw + 1).Value = .Range("A" & x).Value
ws1.Range("C" & MaxrOw + 1).Value = .Range("B" & x).Value
ws1.Range("D" & MaxrOw + 1).Value = .Range("G" & x).Value
ws1.Range("E" & MaxrOw + 1).Value = .Range("H" & x).Value
ws1.Range("F" & MaxrOw + 1).Value = .Range("I" & x).Value
x = x + 1
Else
x = x + 1
End If
Loop
End With
Next i
Columns("A:F").Sort key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes
End Sub
Thanks in advance.
Scott Craner has fixed your syntactical issue, but, as others have mentioned, there are some inefficiencies in your code. Have a look here as a starting point https://msdn.microsoft.com/en-us/library/office/ff726673(v=office.14).aspx.
So, for your code:
The loop through worksheet indexes can't be relied upon. For example, if you moved the "Data" or "Summary" sheet (deliberately or by mistake), you'd risk missing some sheets out of the loop. It's more reliable to loop through the Worksheets collection and testing if each is a worksheet you want, say by its name.
Whenever you're reading to and from the worksheet, it's usually quicker to read and write to/from a variant array. Writing cell by cell, in particular, is notoriously time-consuming.
Finding the last row is also unnecessary for each row iteration. Quicker would be to find it once and then simply add 1 each time you write a line. Of course, quicker still would be point #2.
The code below resolves these three issues. It's not the most memory efficient but it will be quick.
Dim ws As Worksheet
Dim dataSets As Collection
Dim output() As Variant
Dim dataValues(1) As Variant
Dim d As Long
Dim x As Long
Dim v As Variant
'Acquire the data from each sheet and aggregate the output array size
Set dataSets = New Collection
d = 2
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Data" And ws.Name <> "Summary" Then
dataValues(0) = ws.Range("G2").Value
dataValues(1) = ws.Range("A7", ws.Cells(ws.Rows.Count, "A").End(xlUp)).Resize(, 9).Value2
d = d + UBound(dataValues(1), 1)
dataSets.Add dataValues
End If
Next
'Redimension the output array
ReDim output(1 To d, 1 To 6)
'Populate the header
output(1, 1) = "Date"
output(1, 2) = "Equipment"
output(1, 3) = "Type"
output(1, 4) = "Qty / Hrs"
output(1, 5) = "Rate"
output(1, 6) = "Cost"
'Populate the output array with values
d = 2
For Each v In dataSets
For x = 1 To UBound(v(1), 1)
output(d, 1) = v(0)
output(d, 2) = v(1)(x, 1)
output(d, 3) = v(1)(x, 2)
output(d, 4) = v(1)(x, 7)
output(d, 5) = v(1)(x, 8)
output(d, 6) = v(1)(x, 9)
d = d + 1
Next
Next
'Write the array
ThisWorkbook.Worksheets("Data").Range("A1").Resize(UBound(output, 1), UBound(output, 2)).Value = output