I am using Excel 2016 and I have a data set with 492 rows and no headers. Data starts at Cell A1.
An extract of the data set looks like this:
I want to transpose this data set so that it becomes into this format:
I am new to VBA and I am having a hard time finding the right solution. I have tried recording the transpose as a Macro (step by step) and viewed the VBA codes but I still can't make it come together.
Try this code, but before you do adjust the two constants at the top to match the facts on your worksheet. The worksheet with the data must be active when the code is executed.
Sub TransposeData()
Const FirstDataRow As Long = 2 ' presuming row 1 has headers
Const YearColumn As String = "A" ' change as applicable
Dim Rng As Range
Dim Arr As Variant, Pos As Variant
Dim Rl As Long, Cl As Long
Dim R As Long, C As Long
Dim i As Long
With ActiveSheet
Cl = .UsedRange.Columns.Count - .UsedRange.Column + 1
Rl = .Cells(.Rows.Count, Columns(YearColumn).Column).End(xlUp).Row
Set Rng = Range(.Cells(FirstDataRow, YearColumn), .Cells(Rl, Cl))
End With
Arr = Rng.Value
ReDim Pos(1 To (UBound(Arr) * UBound(Arr, 2)), 1 To 2)
For R = 1 To UBound(Arr)
For C = 2 To UBound(Arr, 2)
i = i + 1
Pos(i, 1) = Arr(R, 1)
Pos(i, 2) = Arr(R, C)
Next C
Next R
R = Rl + 5 ' write 5 rows below existing data
Set Rng = ActiveSheet.Cells(R, YearColumn).Resize(i, 2)
Rng.Value = Pos
End Sub
Related
I have:
Column A: (IDs)
A
A
A
C
C
Z
Column B: (Values)
3
2
-6
-12
6
2
I'm trying to create a macro that fills all unique ID's into column C, and counts whether they pass/fail in column D. A pass would be having an associated value in column B between -5 and 5.
Column C/D would look like:
C
D
A
2
C
0
Z
1
If anyone can start me off or link a similar example id appreciate.
You can do it using formulas. But if you like/want VBA, please try the next piece of code. It uses arrays and a dictionary. Working only in memory, it should be very fast, even for large ranges:
Sub CountPassed()
Dim dict As Object, sh As Worksheet, lastR As Long
Dim arr, arrFin, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:B" & lastR).value 'place the range in an array for faster iteration
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr) 'extract unique keys and their item value according to the rule:
dict(arr(i, 1)) = dict(arr(i, 1)) + IIf(arr(i, 2) >= -5 And arr(i, 2) <= 5, 1, 0)
Next i
'create the necessary final array:
ReDim arrFin(1 To dict.count, 1 To 2)
For i = 0 To dict.count - 1
arrFin(i + 1, 1) = dict.Keys()(i)
arrFin(i + 1, 2) = dict.items()(i)
Next i
'drop the final array at once
sh.Range("C2").Resize(UBound(arrFin), 2).value = arrFin
End Sub
Count Unique With Limits
Adjust the values in the constants section.
Option Explicit
Sub CountUniqueWithLimits()
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A1"
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "C1"
Const lLimit As String = ">=-5"
Const uLimit As String = "<=5"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim rCount As Long
With sws.Range(sFirstCellAddress)
Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub
rCount = lCell.Row - .Row + 1
Set srg = .Resize(rCount, 2)
End With
Dim Data As Variant: Data = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Key As Variant
Dim nkey As Variant
Dim r As Long
For r = 1 To rCount
Key = Data(r, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
If Not dict.Exists(Key) Then
dict(Key) = 0
End If
nkey = Data(r, 2)
If IsNumeric(nkey) Then
If Len(nkey) > 0 Then
If Evaluate(nkey & lLimit) Then
If Evaluate(nkey & uLimit) Then
dict(Key) = dict(Key) + 1
End If
End If
End If
End If
End If
End If
Next r
rCount = dict.Count
If rCount = 0 Then Exit Sub
ReDim Data(1 To rCount, 1 To 2)
r = 0
For Each Key In dict.Keys
r = r + 1
Data(r, 1) = Key
Data(r, 2) = dict(Key)
Next Key
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, 2)
.Resize(rCount).Value = Data
.Resize(dws.Rows.Count - .Row - rCount + 1).Offset(rCount).ClearContents
End With
MsgBox "Unique values with limits counted.", vbInformation
End Sub
Well, it may happen you are not familiar of writing VBA Codes, then you may try any of the options using Excel Formula (Formulas Shown Below Are Exclusively For Excel 2021 & O365 Users)
=CHOOSE({1,2},UNIQUE(ID),COUNTIFS(ID,UNIQUE(ID),Values,">=-5",Values,"<=5"))
In the above formula, we are combining two arrays within a CHOOSE Function.
• The first array contains the unique values in the database
UNIQUE(ID)
Where ID refers to the range =$A$3:$A$8, created using the Define Name Manager.
• The second array is essentially the COUNTIFS Function,
COUNTIFS(ID,UNIQUE(ID),Values,">=-5",Values,"<=5")
Where Values refers to the range =$B$3:$B$8, created using the Define Name Manager.
The CHOOSE function combines both the arrays into a single array, which produces as a two-column table as shown in the image below.
Note that we can also use the LET function to elegantly perform, by defining a variable, U to hold the unique values,
• Formula can also be used in cell C3
=LET(U,UNIQUE(ID),CHOOSE({1,2},U,COUNTIFS(ID,U,Values,">=-5",Values,"<=5")))
You may see that this version of the formula calls the UNIQUE function once only, storing the result in U, which is used twice!
Here are the particulars. Let's say you have a 10 X 10 range of cells- A1:J10 will work fine. What I'm trying to find via VBA is how many pairs of non intersecting ranges containing 5 cells and 4 cells can be derived from the main range of A1:J10. For example, A1:A5 (5 cell subset) and A6:A9 (4 cell subset) would be a valid pair. A1:E5 and A1:A4 would not be a valid pair due to the intersection of ranges at A1. I'm mostly just looking for the number of valid pairs, but if somebody can show how to physically list all the pairs on a worksheet as well that would help out.
Thanks in advance for the help!
Range Subset Combinations
Option Explicit
Sub writeRangePairs()
' Source
Const wsName As String = "Sheet1"
Const srcRange = "A1:J10"
Const RC1 As Long = 5
Const RC2 As Long = 4
' Target
Const tgtFirstCell As String = "L1"
' Other
Dim wb As Workbook
Set wb = ThisWorkbook
' Define Source Range.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
Dim rng As Range
Set rng = ws.Range(srcRange)
' Write all possible range addresses
' to Source Arrays ('Source1', 'Source2').
Dim Source1 As Variant
Source1 = getOneRowOneCol(rng, RC1)
Dim Source2 As Variant
Source2 = getOneRowOneCol(rng, RC2)
' Define Target Array. It is too big,
' but It cannot be bigger than UB1 * UB2.
Dim Target As Variant
ReDim Target(1 To UBound(Source1) * UBound(Source2), 1 To 3)
Dim i As Long
Dim k As Long
Dim m As Long
' Write values from Source Arrays to Target Array.
For i = 1 To UBound(Source1)
For k = 1 To UBound(Source2)
If Intersect(ws.Range(Source1(i, 1)), ws.Range(Source2(k, 1))) _
Is Nothing Then
m = m + 1
' Write first range address.
Target(m, 1) = Source1(i, 1)
' Write second range address.
Target(m, 2) = Source2(k, 1)
' Write both addresses as one range address. This column
' will contain duplicates which could be removed
' by using a dictionary.
Target(m, 3) = Union(ws.Range(Source1(i, 1)), _
ws.Range(Source2(k, 1))).Address(0, 0)
End If
Next k
Next i
' Write values from Target Array to Target Range. Since Target Array
' is too big, we are using 'm' instead of 'UBound(Target, 1)'.
ws.Range(tgtFirstCell).Resize(m, UBound(Target, 2)).Value = Target
End Sub
Function getOneRowOneCol(SourceRange As Range, _
ByVal NumberOfCells As Long) _
As Variant
Dim r As Long
r = SourceRange.Rows.Count
Dim c As Long
c = SourceRange.Columns.Count
Dim NoRs As Long
NoRs = r * (c - NumberOfCells + 1)
Dim NoCs As Long
NoCs = c * (r - NumberOfCells + 1)
Dim Data As Variant
ReDim Data(1 To NoRs + NoCs, 1 To 1)
Dim rng As Range
Dim i As Long
Dim j As Long
Dim k As Long
' Rows
For i = 1 To r
For j = 1 To c - NumberOfCells + 1
Set rng = SourceRange.Cells(i, j).Resize(, NumberOfCells)
k = k + 1
Data(k, 1) = rng.Address(0, 0)
Next j
Next i
' Columns
For j = 1 To c
For i = 1 To r - NumberOfCells + 1
Set rng = SourceRange.Cells(i, j).Resize(NumberOfCells)
k = k + 1
Data(k, 1) = rng.Address(0, 0)
Next i
Next j
getOneRowOneCol = Data
' Debug.Print UBound(Data)
' For i = 1 To UBound(Data)
' Debug.Print Data(i, 1)
' Next i
End Function
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 want to write a code that uses two 1D arrays and based on the match with the value on the row, it should return the value in the 3rd array.
This is what I want to do:
In Sheet1, I have 3 columns with data on ID, Name, and Amount with a number of rows of uncertain size:
In Sheet2, I have already the columns with data on ID and Name but I don't have the data on Amount:
Therefore, I want to run the code that will match the arrays with ID and Name data in Sheet1 with ID and Name data in Sheet2 and then, return the respective Amount data to Sheet2 as it is in Sheet1.
This is the desired outcome in Sheet2 after running the code, i.e. the data in column Amount are returned based on the match with arrays on ID and Name in Sheet1:
This is my code that does not run as it should:
Sub ArrayMatch()
Dim r As Long
Dim d As Long
Dim w_output As Worksheet
Dim w1 As Worksheet
Dim intLastRow As Integer
Dim IntLastCol As Integer
Dim arrName() As Variant
Dim arrID() As Variant
Dim arrrAmoun() As Variant
d = 8
With ThisWorkbook
Set w1 = .Sheets("Sheet1")
Set w_output = .Sheets("Sheet2")
End With
'***********************************
'Assign arrays
With w1
intLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
IntLastCol = .Cells(4, Columns.Count).End(xlToLeft).Column
arrID = .Range(.Cells(4, 1), .Cells(intLastRow, 1))
arrName = .Range(.Cells(4, 3), .Cells(intLastRow, 2))
arrAmoun = .Range(.Cells(4, 4), .Cells(intLastRow, 3))
For r = 1 To UBound(arrID, 1)
If Len(arrID(r, 1)) > 0 Then
d = d + 1
If w_output.Cells(d, 1) = arrID(r, 1) Then
If w_output.Cells(d, 2) = arrName(r, 1) Then
w_output.Cells(d, 4) = arrAmoun(r, 1)
End If
End If
End If
Next r
End With
End Sub
My code does not return anything, I can assume that it is because I am comparing the arrays from sheet1 with rows in sheet 2 which is not comparative in the size, but I don't know how to do in another way.
I will appreciate any help.
Just modified your code to include an inner loop to check for ID and name in w_output sheet (it could also be done with Find). Tested with makeshift data. However there are other (more efficient) ways to achieve the same goal.
Sub ArrayMatch()
Dim r As Long
Dim d As Long
Dim w_output As Worksheet
Dim w1 As Worksheet
Dim intLastRow As Long ' Modified to long
Dim IntLastRow1 As Long ' Modified to long
Dim arrName() As Variant
Dim arrID() As Variant
Dim arrrAmoun() As Variant
'd = 8
With ThisWorkbook
Set w1 = .Sheets("Sheet1")
Set w_output = .Sheets("Sheet2")
End With
'***********************************
'Assign arrays
With w1
intLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
IntLastRow1 = w_output.Cells(Rows.Count, 1).End(xlUp).Row
arrID = .Range(.Cells(4, 1), .Cells(intLastRow, 1))
arrName = .Range(.Cells(4, 3), .Cells(intLastRow, 3))
arrAmoun = .Range(.Cells(4, 4), .Cells(intLastRow, 4))
For r = 1 To UBound(arrID, 1)
If Len(arrID(r, 1)) > 0 Then
For d = 9 To IntLastRow1 ' Modified to for loop for w_output sheet
If w_output.Cells(d, 1) = arrID(r, 1) Then
If w_output.Cells(d, 2) = arrName(r, 1) Then
w_output.Cells(d, 4) = arrAmoun(r, 1)
Exit For ' added once found and amount put in place
End If
End If
Next
End If
Next r
End With
End Sub
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