I'm building an excel timesheet to track the temp employees time and OT per job worked. The way things are set up now works okay but I'd like to make it more efficient.
I need to find the unique values from the "Job #" column in the listObject table "MAIN" and copy them to the "Job #" column in the listObject table "SUMMARY".
I'm using excel 365. I've tried using dictionary objects and can't get my head wrapped around it at the moment. I found this bit of code but haven't been able to make it work for me.
Dim arr
Dim x As Long
Dim rng As Range
arr = mainTable.ListColumns("JOB NAME").DataBodyRange
With CreateObject("Scripting.Dictionary")
For x = LBound(arr) To UBound(arr)
If Not IsMissing(arr(x, 1)) Then .Item(arr(x, 1)) = 1
Next
arr = .Keys
End With
Set tbl = Worksheets("Summary by Job").ListObjects("SUMMARY")
Set rng = Range("SUMMARY[#All]").Resize(UBound(arr, 1), tbl.Range.Columns.Count)
tbl.HeaderRowRange.Resize(UBound(arr, 1) + 1).Offset(1).Value = Application.Transpose(arr)
Once I got this adjusted for spreadsheet it copied the data across all of the columns. I also would like a way to return the number of unique entries.
may try something like this (please modify sheet name table names to your requirement, i tried to keep it similar for test purpose).in VBA project added reference to "Microsoft scripting runtime"
Sub test()
Dim Arr As Variant, Rslt As Variant, X As Long
Dim Rng As Range, Dict As Dictionary
Dim Tbl As ListObject, MainTable As ListObject
Dim Ws As Worksheet, RsltCnt As Long, ColCnt As Long
Set Ws = ThisWorkbook.Worksheets("Summary by Job")
Set MainTable = Ws.ListObjects("MAIN")
Set Tbl = Ws.ListObjects("SUMMARY")
ColCnt = MainTable.HeaderRowRange.Columns.Count
Arr = MainTable.DataBodyRange
ReDim Rslt(1 To ColCnt, 1 To 1)
Set Dict = CreateObject("Scripting.Dictionary")
RsltCnt = 1
For X = 1 To UBound(Arr, 1)
If Dict.Exists(Arr(X, 1)) = False Then
Dict.Add Arr(X, 1), 1
ReDim Preserve Rslt(1 To ColCnt, 1 To RsltCnt)
For Y = 1 To ColCnt
Rslt(Y, RsltCnt) = Arr(X, Y)
Next
RsltCnt = RsltCnt + 1
Else
Dict(Arr(X, 1)) = Dict(Arr(X, 1)) + 1 ' Dict will hold the count of unique key value
End If
Next
'this would copy the unique array at the end of table SUMMARY
Tbl.DataBodyRange(Tbl.DataBodyRange.Rows.Count, 1).Offset(1, 0).Resize(UBound(Rslt, 2), UBound(Rslt, 1)).Value = Application.Transpose(Rslt)
End Sub
Related
Using Application.Match Function but unable to know how to paste the Col"M" data into Col"P" after the Matching the Col"O" and Col"L".
When run the Current function it gives the count of match.
Any help will be appreciated.
Dim k As Integer
For k = 2 To 9
ws2.Cells(k, 16).Value = Application.Match(ws2.Cells(k, 15).Value, ws2.Range("L2:L9"), 0)
Next k
I have edited the code with the columns and in which column the result is required. But unable to make changes I really appreciate your help that you make this function. I added some comments may it can help.
' Sheet2 Col"C" with ID's
With ws2
Dim lastRow As Long
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim originalData() As Variant
originalData = .Range("C2:C" & lastRow).Value
End With
' Sheet2 Col"C" with ID's
With ws3
Dim lastRow2 As Long
lastRow2 = .Range("A" & .Rows.Count).End(xlUp).Row
Dim newData() As Variant
newData = .Range("C2:C" & lastRow2).Value
End With
Dim i As Long
For i = LBound(newData, 1) To UBound(newData, 1)
Dim j As Long
For j = LBound(originalData, 1) To UBound(originalData, 2)
If newData(i, 1) = originalData(j, 1) Then
newData(i, 2) = originalData(j, 2)
Exit For
End If
Next
Next
'Sheet2 Col"K" where Sheet3 Col"E" data will be pasted
ws2.Range("K2:K" & lastRow).Value = newData
A scripting dictionary which maps "keys" to "values" is typically the fastest approach when you need to perform a lot of lookups. It's a bit more code to write but should be quick.
Sub DoLookup()
Dim arrKeys, arrValues, wsData As Worksheet, wsDest As Worksheet
Dim map As Object, rngSearch As Range, rngResults As Range, k, v, n As Long
Set wsData = ThisWorkbook.Worksheets("Sheet3") 'sheet with the lookup table
Set wsDest = ThisWorkbook.Worksheets("Sheet2") 'sheet to be populated
arrKeys = wsData.Range("C2:C" & LastRow(wsData, "C")).Value 'keys in the lookup table
arrValues = wsData.Range("G2:G" & LastRow(wsData, "C")).Value 'values in the lookup table
Set map = MapValues(arrKeys, arrValues) 'get a map of Keys->Values
Set rngSearch = wsDest.Range("C2:C" & LastRow(wsDest, "c")) 'keys to look up
Set rngResults = rngSearch.EntireRow.Columns("K") 'results go here
arrKeys = rngSearch.Value 'keys to look up
arrValues = rngResults.Value 'array to populate with results
For n = 1 To UBound(arrKeys) 'loop over keys to look up
v = "" 'or whatever you want to see if no match
k = arrKeys(n, 1)
If map.exists(k) Then v = map(k)
arrValues(n, 1) = v
Next n
rngResults.Value = arrValues 'populate the results array back to the sheet
End Sub
'Return a Scripting Dictionary linking "keys" to "values"
' Note - assumes same-size single-column inputs, and that keys are unique,
' otherwise you just map to the *last* value for any given key
Function MapValues(arrKeys, arrValues)
Dim n, dict As Object, k
Set dict = CreateObject("scripting.dictionary")
For n = 1 To UBound(arrKeys, 1)
k = CStr(arrKeys(n, 1)) 'string keys are faster to add?
If Len(k) > 0 Then dict(k) = arrValues(n, 1)
Next n
Set MapValues = dict
End Function
'utility function
Function LastRow(ws As Worksheet, col As String) As Long
LastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
End Function
In my test workbook this was able to perform 10k lookups against a table of 10k rows in <0.1 sec.
You always should test if the Match succeeded, using IsError.
Then use Cells:
Dim k As Long
For k = 2 To 9
Dim m As Variant
m = Application.Match(ws2.Cells(k, 15).Value, ws2.Range("L2:L9"), 0)
If Not IsError(m) Then
ws2.Cells(k, 16).Value = ws2.Range("M2:M9").Cells(m)
End If
Next
I have a large table of lab measurement logs, which I work with using arrays.
(Im a chemist, a lab technician and Ive started to learn VBA only last week, please bear with me.)
Im trying to figure out, how to load the table into an array and then remove rows with an empty value in the 5th column so that I can "export" the table without blanks in the 5th column via an array into a different sheet.
I first tested this with some code I found for a 1D array, where I would make 2 arrays, one placeholder array which Id loop through adding only non-blanks to a second array.
For Counter = LBound(TestArr) To UBound(TestArr)
If TestArr(Counter, 1) <> "" Then
NoBlankSize = NoBlankSize + 1
NoBlanksArr(UBound(NoBlanksArr)) = TestArr(Counter, 1)
ReDim Preserve NoBlanksArr(0 To UBound(NoBlanksArr) + 1)
End If
Next Counter
It works in 1D, but I cant seem to get it two work with 2 dimensions.
Heres the array Im using for reading and outputting the data
Sub ArrayTest()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim TestArray() As Variant
Dim Dimension1 As Long, Dimension2 As Long
Sheets("Tracker").Activate
Dimension1 = Range("A3", Range("A2").End(xlDown)).Cells.Count - 1
Dimension2 = Range("A2", Range("A2").End(xlToRight)).Cells.Count - 1
ReDim TestArray(0 To Dimension1, 0 To Dimension2)
'load into array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
TestArray(Dimension1, Dimension2) = Range("A4").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
Sheets("Output").Activate
ActiveSheet.Range("A2").Select
'read from array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
ActiveCell.Offset(Dimension1, Dimension2).Value = TestArray(Dimension1, Dimension2)
Next Dimension2
Next Dimension1
Erase TestArray
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Thank you for any help in advance.
The Redim Preserve statement does not work for two-dimensional arrays if you want to change the number of records (rows).
You could load the range into an array, and then when you want to export the array to another range, loop through that array while skipping blank records.
An example:
Option Explicit
Sub ArrayTest()
Dim wb As Workbook, wsInput As Worksheet, wsOutput As Worksheet
Dim myArr As Variant
Dim i As Long, k As Long, LRow As Long
Set wb = ThisWorkbook
Set wsInput = wb.Sheets("Tracker")
Set wsOutput = wb.Sheets("Output")
LRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row + 1
'Load a range into the array (example range)
myArr = wsInput.Range("A1:Z100")
'Fill another range with the array
For i = LBound(myArr) To UBound(myArr)
'Check if the first field of the current record is empty
If Not Len(myArr(i, 1)) = 0 Then
'Loop through the record and fill the row
For k = LBound(myArr, 2) To UBound(myArr, 2)
wsOutput.Cells(LRow, k) = myArr(i, k)
Next k
LRow = LRow + 1
End If
Next i
End Sub
From your code, it appears you want to
test a column of data on a worksheet to see if there are blanks.
if there are blanks in the particular column, exclude that row
copy the data with the excluded rows to a new area
You can probably do that easier (and quicker) with a filter: code below checking for blanks in column2
Option Explicit
Sub removeCol2BlankRows()
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim rSrc As Range, rRes As Range
Set wsSrc = ThisWorkbook.Worksheets("sheet1")
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion 'many ways to do this
Set wsRes = ThisWorkbook.Worksheets("sheet1")
Set rRes = wsRes.Cells(1, 10)
If wsSrc.AutoFilterMode = True Then wsSrc.AutoFilterMode = False
rSrc.AutoFilter field:=2, Criteria1:="<>"
rSrc.SpecialCells(xlCellTypeVisible).Copy rRes
wsRes.AutoFilterMode = False
End Sub
If you really just want to filter the VBA arrays in code, I'd store the non-blank rows in a dictionary, and then write it back to the new array:
Option Explicit
Sub removeCol2BlankRows()
Dim testArr As Variant
Dim noBlanksArr As Variant
Dim myDict As Object
Dim I As Long, J As Long, V
Dim rwData(1 To 4) As Variant
With ThisWorkbook.Worksheets("sheet1")
testArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With
Set myDict = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(testArr, 1)
If testArr(I, 2) <> "" Then
For J = 1 To UBound(testArr, 2)
rwData(J) = testArr(I, J)
Next J
myDict.Add Key:=I, Item:=rwData
End If
Next I
ReDim noBlanksArr(1 To myDict.Count, 1 To 4)
I = 0
For Each V In myDict.keys
I = I + 1
For J = 1 To 4
noBlanksArr(I, J) = myDict(V)(J)
Next J
Next V
End Sub
What I am trying to do is looping through all rows and columns to find the quantity of a part inside a machine. This is searched for based on the article number and the Equipment/machine type. As in this screenshot:
My problem is that the way I have it running now is VERY slow. In the screenshot above is only a small portion of the cells. They go down to +-500 equalling roughly 22500 times the formula:
=ifERROR(INDEX(Datasheet!$B$1:$E$100;MATCH(1;(Datasheet!$D:$D=C$1)*(Datasheet!$B:$B=$AY15);0);4);"")
I want to speed it up using VBA by just giving my static values in all cells.
I have a large part done which I will display below.
The search values (datasheet)
I have it almost complete (I can feel it!) but it keeps returning me the type 13 Type mismatch error. I have found MANY MANY threads on stack overflow and the internet but these fixes do not fix it for myself.
My code:
'set all sheets
'----------------------------------------
Dim Isht As Worksheet
Dim Esht As Worksheet
Dim Dsht As Worksheet
Dim Gsht As Worksheet
Set Isht = ThisWorkbook.Worksheets("Instructionsheet")
Set Esht = ThisWorkbook.Worksheets("Exportsheet")
Set Dsht = ThisWorkbook.Worksheets("Datasheet")
Set Gsht = ThisWorkbook.Worksheets("Gathersheet")
'----------------------------------------
Dim EshtLR As Long
Dim EshtLC As Long
Dim DshtLC As Long
Dim DshtLR As Long
Dim OutputRange As Range
Dim SearchRange As Range
Dim MachineMatchCOL As Range
Dim ArticleMatchCOL As Range
Dim MachineType As String
Dim ArticleNumber As String
Dim StartRow As Long
Dim StartCol As Long
StartCol = Dsht.Range("P10").Value
StartRow = Dsht.Range("P11").Value
'Determine Last column in export sheet.
EshtLC = Esht.Cells(14, Columns.count).End(xlToLeft).Column
'Determine Last row in data sheet.
DshtLR = Dsht.Cells(Rows.count, 1).End(xlUp).Row
'Determine Last row in export sheet.
EshtLR = Esht.Cells(Rows.count, 1).End(xlUp).Row
Set OutputRange = Esht.Range(Esht.Cells(StartRow, 3), Esht.Cells(EshtLR, EshtLC - 9))
Set SearchRange = Dsht.Range(Dsht.Cells(1, 2), Dsht.Cells(DshtLR, 5))
Set MachineMatchCOL = Dsht.Range(Dsht.Cells(1, 4), Dsht.Cells(DshtLR, 4))
Set ArticleMatchCOL = Dsht.Range(Dsht.Cells(1, 2), Dsht.Cells(DshtLR, 2))
'=IFERROR(INDEX(Datasheet!$B$1:$E$100;Match(1;(Datasheet!$D:$D=C$1)*(Datasheet!$B:$B=$AY15);0);4);"")
'Datasheet!$B$1:$E$100 = SearchRange
'Datasheet!$D:$D = MachineMatchCOL
'Datasheet!$B:$B = ArticleMatchCOL
'C$1 = MatchineType
'$AY15 = ArticleNumber
j = StartRow
i = StartCol
For Each Row In OutputRange
For Each Column In OutputRange
MachineType = Esht.Range(Esht.Cells(1, i), Esht.Cells(1, i)).Value
ArticleNumber = Esht.Range(Cells(j, EshtLC - 5), Cells(j, EshtLC - 5)).Value
Esht.Cells(j, i).Value = Application.WorksheetFunction _
.IfError(Application.WorksheetFunction _
.Index(SearchRange, Application.WorksheetFunction _
.Match(1, (MachineMatchCOL = MachineType) * (ArticleMatchCOL = ArticleNumber), 0), 4), "")
i = i + 1
Next Column
j = j + 1
Next Row
It has something to do with the fact that a range cannot equal a value but I have tried for a long time and cannot figure it out.
Also note that the loop probably does not work but that is for a next problem to deal with :-).
I do not expect you to fully create everything but, again, a friendly push is also greatly appreciated.
UPDATE: The line that arises error is:
Esht.Cells(j, i).Value = Application.WorksheetFunction _
.IfError(Application.WorksheetFunction _
.Index(SearchRange, Application.WorksheetFunction _
.Match(1, (MachineMatchCOL = MachineType) * (ArticleMatchCOL = ArticleNumber), 0), 4), "")
Build a dictionary of the Datasheet values using columns B & D joined as the key and column E as the item. This will provide virtually instantaneous 'two-column' lookup for the C15:AU29 table on the Exportsheet worksheet.
Option Explicit
Sub PopulateQIMs()
Dim i As Long, j As Long, ds As Object
Dim arr As Variant, typ As Variant, art As Variant, k As Variant
Set ds = CreateObject("scripting.dictionary")
'populate a dictionary
With Worksheets("datasheet")
'collect values from ws into array
arr = .Range(.Cells(3, "B"), .Cells(.Rows.Count, "E").End(xlUp)).Value2
'cycle through array and build dictionary
For i = LBound(arr, 1) To UBound(arr, 1)
'shorthand overwrite method of creating dictionary entries
'key as join(column B & column D), item as column E
ds.Item(Join(Array(arr(i, 1), arr(i, 3)), Chr(0))) = arr(i, 4)
Next i
End With
With Worksheets("exportsheet")
'collect exportsheet 'Type' into array
'typ = .Range(.Cells(1, "C"), .Cells(1, "AU")).Value2
typ = .Range(.Cells(1, "C"), .Cells(1, "C").End(xlToRight)).Value2
'collect exportsheet 'Article Number' into array
'art = .Range(.Cells(15, "AY"), .Cells(29, "AY")).Value2
art = .Range(.Cells(15, "AY"), .Cells(15, "AY").End(xlDown)).Value2
'create array to hold C15:AU29 values
'ReDim arr(1 To 15, 1 To 45)
ReDim arr(LBound(art, 1) To UBound(art, 1), _
LBound(typ, 2) To UBound(typ, 2))
'cycle through Type and Article Numbers and populate array from dictionary
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
'build a key for lookup
k = Join(Array(art(i, 1), typ(1, j)), Chr(0))
'is it found ...?
If ds.exists(k) Then
'put 'Quantity In Machine' into array
arr(i, j) = ds.Item(k)
End If
Next j
Next i
'put array values into Exportsheet
.Cells(15, "C").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
Not sure this exactly meets your needs, nor being the most elegant solution - and running out of time to make this more nicer...
It might not work for you straight out of the box, but i hope it gives you an idea on how to better aproach this.
Sub test()
'set all sheets
'----------------------------------------
Dim Isht As Worksheet
Dim Esht As Worksheet
Dim Dsht As Worksheet
Dim Gsht As Worksheet
Set Isht = ThisWorkbook.Worksheets("Instructionsheet")
Set Esht = ThisWorkbook.Worksheets("Exportsheet")
Set Dsht = ThisWorkbook.Worksheets("Datasheet")
Set Gsht = ThisWorkbook.Worksheets("Gathersheet")
'----------------------------------------
Dim EshtLR As Long
Dim EshtLC As Long
Dim DshtLC As Long
Dim DshtLR As Long
Dim OutputRange As Range
Dim SearchRange As Range
Dim MachineMatchCOL As Range
Dim ArticleMatchCOL As Range
Dim MachineType As String
Dim ArticleNumber As String
Dim StartRow As Long
Dim StartCol As Long
StartCol = Dsht.Range("P10").Value
StartRow = Dsht.Range("P11").Value
'Determine Last column in export sheet.
EshtLC = Esht.Cells(14, Columns.Count).End(xlToLeft).Column
'Determine Last row in data sheet.
DshtLR = Dsht.Cells(Rows.Count, 1).End(xlUp).row
'Determine Last row in export sheet.
EshtLR = Esht.Cells(Rows.Count, 1).End(xlUp).row
'Declare and allocate your ranges to arrays
Dim arrOutput As Variant, arrSearch As Variant
arrOutput = Esht.Range(Esht.Cells(1, 3), Esht.Cells(EshtLR, EshtLC)) 'Not sure what last column is here, but i will make a presumption below that "Article number" is last
arrSearch = Dsht.Range(Dsht.Cells(1, 2), Dsht.Cells(DshtLR, 5))
Dim R As Long, C As Long, X As Long
For R = LBound(arrOutput) To UBound(arrOutput)
For C = LBound(arrOutput, 2) To UBound(arrOutput, 2)
For X = LBound(arrSearch) To UBound(arrSearch)
'If the article number has a match in the search
If arrOutput(R, UBound(arrOutput)) = arrSearch(X, 1) Then 'replace UBound(arrOutput) with the "Article number" column number
'Let's check if the machine number is there as well
If arrOutput(1, C) = arrSearch(X, 3) Then
'both found at the same row, return the value from that row
arrOutput(R, C) = arrSearch(X, 4)
End If
End If
Next X
Next C
Next R
End Sub
PS: You still need to write the values back to the sheet from the array, which you can either do directly range = array or through a loop, depending on your needs.
I`ll try to complete the answer later when i get more time (at work!).
I would like to extract unique values based on a criteria. This is what I have so far:
Sub test()
Dim x As Variant
Dim objdict As Object
Dim lngrow As Long
With Sheets("Sheet1")
Set objdict = CreateObject("Scripting.Dictionary")
x = Application.Transpose(.Range("A1", .Range("A1").End(xlDown)))
For lngrow = 1 To UBound(x, 1)
objdict(x(lngrow)) = 1
Next
.Range("C1:C" & objdict.Count) = Application.Transpose(objdict.keys)
End With
End Sub
Below what I would like to achieve:
As you can see the values are in column A, the criteria are in column B and the unique values are in column C. Can anyone show me what I need to change in my code?
You're almost there! See the comments in the code below:
Option Explicit
Sub Test()
Dim x As Variant
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
With Sheet1 '<== You can directly use the (Name) property of the worksheet as seen from the VBA editor.
x = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(XlDirection.xlUp)).Value
For lngRow = 1 To UBound(x, 1)
If x(lngRow, 2) = 1 Then '<== Example criteria: value is 1 in column B.
objDict(x(lngRow, 1)) = 1 '<== Don't know if this is significant in your case (I typically assign True).
End If
Next
.Range(.Cells(1, 3), .Cells(objDict.Count, 3)).Value = Application.Transpose(objDict.Keys)
End With
'Cleanup.
Set objDict = Nothing
End Sub
Note that I've replaced the strings used within Range() by the numeric indices (row, column), which IMHO is better practice.
I am trying to make edge relation from excel file which are organized in rows,
A,B,C,
D,E
the aim is to create relationships from each row:
A,B
A,C
B,C
I have the following codes , the problem is the codes is efficient when rows are equal in length but for example for above rows it create also following edges (relationship):
D," "
E, " "
Which create big problem for large data set. I was wondering if some body can help me to adjust the code the way to create the edge list only till filled cells in each row. If there is any other way to do this more efficient will appreciate it.
Thank you so much,Will be great help.
My code:
Sub Transform()
Dim targetRowNumber As Long
targetRowNumber = Selection.Rows(Selection.Rows.Count).Row + 2
Dim col1 As Variant
Dim cell As Range
Dim colCounter As Long
Dim colCounter2 As Long
Dim sourceRow As Range: For Each sourceRow In Selection.Rows
For colCounter = 1 To Selection.Columns.Count - 1
col1 = sourceRow.Cells(colCounter).Value
For colCounter2 = colCounter + 1 To Selection.Columns.Count
Set cell = sourceRow.Cells(, colCounter2)
If Not cell.Column = Selection.Column Then
Selection.Worksheet.Cells(targetRowNumber, 1) = col1
Selection.Worksheet.Cells(targetRowNumber, 2) = cell.Value
targetRowNumber = targetRowNumber + 1
End If
Next colCounter2
Next colCounter
Next sourceRow
End Sub
I've played around with it - this should do the trick. We can probably speed it up by outputting to another variant array if needed, but this ran pretty quickly for me:
Sub Transform_New()
Dim rngSource As Range, rngDest As Range
Dim varArray As Variant
Dim i As Integer, j As Integer, k As Integer
Set rngSource = Sheet1.Range("A1", Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1)) 'Put all used rows into range
Set rngDest = Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1).Offset(2, 0) 'Set target range to start 2 below source range
varArray = Range(rngSource, rngSource.Offset(0, Range("A1").SpecialCells(xlCellTypeLastCell).Column)).Value
For i = LBound(varArray, 1) To UBound(varArray, 1) 'Loop vertically through array
For j = LBound(varArray, 2) To UBound(varArray, 2) 'Loop horizontally through each line apart from last cell
k = j
Do Until varArray(i, k) = ""
k = k + 1
If varArray(i, k) <> "" Then
rngDest.Value = varArray(i, j)
rngDest.Offset(0, 1).Value = varArray(i, k)
Set rngDest = rngDest.Offset(1, 0)
End If
Loop
Next
Next
End Sub