Perhaps I'm trying to do too much, but I have a column filled with text. Each cell has an arbitrary number of words, so for example:
| A |
=====|====================|
1 | apple pear yes cat |
2 | apple cat dog |
3 | pear orange |
What I need to do is create a column which is a list of all unique words in that range. So for the above example, the result should be:
| A | B |
=====|====================|========|
1 | apple pear yes cat | apple |
2 | apple cat dog | pear |
3 | pear orange | yes |
4 | | cat |
5 | | dog |
6 | | orange |
In no particular order. Is there any way to do this?
This option uses 1 loop instead of 3, I like to use a dictionary instead or Collection.
Sub Sample()
Dim varValues As Variant
Dim strAllValues As String
Dim i As Long
Dim d As Object
'Create empty Dictionary
Set d = CreateObject("Scripting.Dictionary")
'Create String With all possible Values
strAllValues = Join(Application.Transpose(Range("A1", Range("A" & Rows.Count).End(xlUp))), " ")
'Split All Values by space into array
varValues = Split(strAllValues, " ")
'Fill dictionary with all values (this filters out duplicates)
For i = LBound(varValues) To UBound(varValues)
d(varValues(i)) = 1
Next i
'Write All The values back to your worksheet
Range("B1:B" & d.Count) = Application.Transpose(d.Keys)
End Sub
Give this small macro a try:
Sub dural()
Dim N As Long, U As Long, L As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
Dim st As String
For I = 1 To N
st = st & " " & Cells(I, 1)
Next I
st = Application.WorksheetFunction.Trim(st)
ary = Split(st, " ")
U = UBound(ary)
L = LBound(ary)
Dim c As Collection
Set c = New Collection
On Error Resume Next
For I = L To U
c.Add ary(I), CStr(ary(I))
Next I
For I = 1 To c.Count
Cells(I, 2).Value = c.Item(I)
Next I
End Sub
Related
In the previous post you guys helped me to find out a solution in order to copy-paste cells.
By now I've got a slight different problem.
Here is it; I've got 2 different sheets;
worksheets("Food")
Worksheets("Numbers")
In worksheets("Food"), I've got the following board;
| Fruits | Vegetables |
| -------- | --------------|
| Banana | Carrots |
| Peach | Spinachs |
| Pineapple | Cauliflowers |
In worksheets("Numbers"), I've got this;
| Fruits | Numbers |
| -------- | --------- |
| Banana | 9 |
| Apple | 2 |
| Orange | 3 |
| Peach | 7 |
| Pineapple | 5 |
I'd like to search for each fruits from worksheets("Food") if they do exist in worksheets("Numbers"). If yes, then automatically insert a new column in worksheets("Food") between column Fruits and Vegetables named "Numbers".
After, picked up numbers beside each found fruits in worksheets("Numbers") and paste it in worksheets("Food") beside the matching fruit in the new created column.
Like this;
| Fruits |*Numbers* |Vegetables
| -------- |-------------- |------------
| Banana |**9** |Carrots
| Peach |**7** |Spinachs
| Pineapple |**5** |Cauliflowers
I've been trying to run a code doing this process but as I run it nothing happens ( no error occurs neither)...
Here is it;
Sub Add_Fruits_Numbers()
Dim lastlineFood As Long
Dim lastlineRef As Long
Dim j, i, compteur As Integer
Dim x As Long, rng As range
lastlineRef = Worksheets("Numbers").range("A" & rows.Count).End(xlUp).row
For j = 1 To lastlineRef
lastlineFood = Worksheets("Food").range("A" & rows.Count).End(xlUp).row
For i = 1 To lastlineFood
If range("A" & i).Value = Worksheets("Numbers").range("A" & j).Value Then
Set rng = Worksheets("Numbers").range("A1", range("A1").End(xlToRight))
For Each cell In rng
If cell.Value = "Fruits" Then
cell.EntireColumn.Offset(0, 1).Insert (xlShiftToRight)
End If
Next cell
Worksheets("Food").range("A" & i).Offset(, 1).Value = Worksheets("Numbers").range("A" & j).Offset(, 1)
End If
Next i
Next j
End Sub
I'd heavily appreciate your help once again, thank you !
Your code has some problems. It should raise an error on the line
Set rng = Worksheets("Numbers").range("A1", range("A1").End(xlToRight))
if the active sheet is not "Numbers". range("A1").End(xlToRight) refers the active sheet. The correct code should be:
Set rng = Worksheets("Numbers").range("A1", Worksheets("Numbers").range("A1").End(xlToRight))
Then, your code inserts a column in the "Numbers" sheet.
You should use Range("B" & i).EntireColumn.Insert instead of cell.EntireColumn.Offset(0, 1).Insert (xlShiftToRight). cell belongs to the range in "Numbers" sheet.
The code logic is wrong. The above sequence must be run only once. Otherwise it will insert a column for each match. "Fruits" will be there of each iteration.
Then everything is messed up and debugging more has no sense, no offence...
It is easier to show you a simpler/faster code, doing what (I understood) you want.
Please, try the next code:
Sub bringFruitsNo()
Dim shF As Worksheet, shN As Worksheet, lastRF As Long, lastRN As Long
Dim arrF, rngN As Range, mtch, i As Long, boolOK
Set shF = Sheets("Food")
Set shN = Sheets("Numbers")
lastRF = shF.Range("A" & shF.rows.count).End(xlUp).row 'last row
lastRN = shN.Range("A" & shN.rows.count).End(xlUp).row 'last row
If shF.Range("B1").value = "Numbers" Then boolOK = True 'check if the column has already been inserted in a previous run
arrF = shF.Range("A2:A" & lastRF).value 'put the first column in an array (for a faster iteration)
Set rngN = shN.Range("A2:A" & lastRN) 'set the range where to search for the fruit existence
For i = 1 To UBound(arrF) 'iterate between the array elements:
mtch = Application.match(arrF(i, 1), rngN, 0) 'if the fruit has bee found:
If IsNumeric(mtch) Then
'insert the new necessary column and mark the inserting event changing the boolean variable value
If Not boolOK Then shF.Range("B1").EntireColumn.Insert: shF.Range("B1").value = "Numbers": boolOK = True
shF.Range("B" & i + 1) = shN.Range("B" & mtch + 1).value 'Place the number in the new column
End If
Next i
End Sub
But, I think you maybe will need to use this code after the column has been inserted, and the code is checking if between "Fruits" and "Vegetables" a column named "Numbers" exists...
If not necessary, and always the code must insert a column between the first and the third column, that line can be deleted.
This was solved using a formula.
Unfortunately, I need a solution that works in Excel 2016, and it seems VBA is the best/only route.
Legend: (this is across multiple worksheets in the same workbook)
Each column has a header.
Column A of Sheet3: List of Names
Column H of Sheet3: List of Email Addresses
Column M of Sheet1: contains the below formula dragged down, which produces a variable number of rows of data:
=IFERROR(INDEX($A$2:$A$42,MATCH(0,IF("1"=$L$2:$L$42,COUNTIF($O$1:$O1,$A$2:$A$42),""),0)),"")
In column M of Sheet1, I have an Index/Match formula, which populates with a list of people's names. (As said above, the number of names that appear is ever-changing.)
I'd like to look up each name that appears in column M of Sheet1 against column A of Sheet3 then return the respective email address from column H of Sheet3.
Additionally, I'd like to separate each email address with a semicolon, as this is to populate the To field of an Outlook email.
Snapshot of what the data looks like
| A, Sheet3 | H, Sheet3 | M, Sheet1 |
| --------------- | ------------------------ | ------------- |
| John Smith | JohnSmith#email.com | Frank Sinatra |
| Kimberly Jones | Kimberly#email.com | Corey Smith |
| Joe Montana | JoeMontana#email.com | Kimberly Jones|
| Dean Martin | DeanMartin#email.com | John Smith |
| Corey Smith | Corey.Smith#email.com | |
| Frank Sinatra | Frank.Sinatra#email.com | |
In cell F2 of Sheet1, the macro would produce the below:
Frank.Sinatra#email.com; Corey.Smith#email.com; Kimberly#email.com; JohnSmith#email.com
Worksheet tab names:
Worksheet1:
Worksheet3:
Try,
Function JoinEmail() As String
Dim Ws(1 To 2) As Worksheet
Dim vDB As Variant, vR() As Variant
Dim vName As Variant
Dim Dic As Object 'Dictionary
Dim i As Long, n As Integer
Dim s As String
Set Ws(1) = Sheets(1)
Set Ws(2) = Sheets(3)
Set Dic = CreateObject("Scripting.Dictionary")
vDB = Ws(2).UsedRange 'Sheets(3) data
With Ws(1)
vName = .Range("M2", .Range("M" & Rows.Count).End(xlUp))
End With
For i = 2 To UBound(vDB, 1)
Dic.Add vDB(i, 1), vDB(i, 8) 'name, email
Next i
For i = 1 To UBound(vName, 1)
s = vName(i, 1)
If Dic.Exists(s) Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = Dic(s)
End If
Next i
If n Then
JoinEmail = Join(vR, "; ")
Else
JoinEmail = ""
End If
End Function
Sheet1 image
Sheet3 image
I'm trying to delete all duplicate values from a column of numbers in Excel. I want the remaining column to only contain unique values from the original table.
I have tried using the RemoveDuplicates method but it only removes a single instance of a duplicate instead of all of them.
I have also tried using the following code but it has the same problem as RemoveDuplicates. I'm not sure why though since the "Unique" tag is set to "True".
{MYWORKSHEET]AdvancedFilter Action:= _
xlFilterCopy, CopyToRange:=[MYWORKSHEET].Range("B1"), Unique:=True
I have only found one solution that should work theoretically that uses a nested For loop to iterate over every individual row and check if it is equivalent to any other row in the table. The only problem is that this crashes Excel on my machine because it has to loop so much. Is there any way to do this other than this brute force method?
Here is what I'm looking for:
|-------| |----------------| |-------------------|
| INPUT | | DESIRED OUTPUT | | WHAT I DONT WANT |
|-------| |----------------| |-------------------|
| 11111 | | 11111 | | 11111 |
|-------| |----------------| |-------------------|
| 22222 | | 55555 | | 22222 |
|-------| |----------------| |-------------------|
| 33333 | | 33333 |
|-------| |-------------------|
| 22222 | | 55555 |
|-------| |-------------------|
| 33333 |
|-------|
| 55555 |
|-------|
Use the Advanced Filter with a formula criteria of, for example: =COUNTIF($A$6:$A$11,A6)=1
Result:
If you need to use a formula instead, you can do something like:
=IFERROR(INDEX(inputTbl,AGGREGATE(15,6,1/(COUNTIF(inputTbl[Input],inputTbl[Input])=1) * ROW(inputTbl)-ROW(inputTbl[#Headers]),ROWS($1:1))),"")
You can load the values into a dictionary and set the value of the key to false, check if the key exists and if so change the value to true. Iterate through the dictionary and only dump keys that are false.
dim mydict as object
dim iter as long
dim lastrow as long
dim cellval as string
dim dictkey as variant
set mydict = createobject("Scripting.Dictionary")
with activesheet
lastrow = .Cells(.Rows.Count, "ColumnLetter").End(xlUp).row
for iter = 1 to lastrow
cellval = .cells(iter, "ColumnLetter").value
if not mydict.exists(cellval) then
mydict.add cellval, False
else
mydict(cellval) = True
end if
next
iter = 1
for each dictkey in mydict
if mydict(dictkey) = False then
.cells(iter, "ColumnLetter").value = dictkey
iter = iter + 1
end if
next
end with
Well, here's a macro to actually do the deletions, or at least get you started:
Private Sub CommandButton1_Click()
Dim celll, rng As Range
Dim strRow, strRowList As String
Dim strRows() As String
Set rng = Range("a1:a" & Range("a1").End(xlDown).Row)
For Each celll In rng
If celll.Address = rng(1, 1).Address Then
If celll.Value = celll.Offset(1, 0).Value Then strRow = celll.Row
ElseIf celll.Value = celll.Offset(-1, 0).Value Or celll.Value = celll.Offset(1, 0).Value Then
strRow = celll.Row
End If
If strRowList = "" Then
strRowList = strRow
ElseIf strRow <> "" Then
strRowList = strRowList & "," & strRow
End If
strRow = ""
Next
MsgBox (strRowList)
strRows() = Split(strRowList, ",")
For i = UBound(strRows) To 0 Step -1
Rows(strRows(i)).Delete
Next
End Sub
I'm new to PowerPivot/DAX and I'm having some trouble with a specific issue I'm trying to resolve. I have a series of products across multiple stores and need to ship a certain amount from as few stores as possible.
A table Products contains a list of products and the needed amounts:
Product | Need
0000001 | 7
0000002 | 8
Another table Stores contains the units available by store and I need to calculate how many to send from each store:
Product | Store | Units | Send
0000001 | 00001 | 5 | 5
0000001 | 00002 | 2 | 2
0000001 | 00003 | 1 | 0
0000002 | 00001 | 0 | 0
0000002 | 00002 | 3 | 1
0000002 | 00003 | 3 | 3
0000002 | 00004 | 4 | 4
0000002 | 00005 | 2 | 0
I have thought of adding a couple of columns for the calculation:
Product | Store | Units | Rank | CSum | Send
0000001 | 00001 | 5 | 1 | 5 | 5
0000001 | 00002 | 2 | 2 | 7 | 2
0000001 | 00003 | 1 | 3 | 8 | 0
0000002 | 00001 | 0 | 5 | 12 | 0
0000002 | 00002 | 3 | 3 | 10 | 1
0000002 | 00003 | 3 | 2 | 7 | 3
0000002 | 00004 | 4 | 1 | 4 | 4
0000002 | 00005 | 2 | 4 | 12 | 0
First, I rank the stores within each product by units available, solving ties at random:
Rank := IF(Units>0,RANKX(ALL(Stores,Stores[Product]),Stores[Units]+RAND())
Then, I calculate the cumulative sum:
CSum := CALCULATE(SUM(Stores[Units]),
FILTER(ALL(Stores,Stores[Product]),Stores[Rank]<=MAX(Stores[Rank])))
Finally, I calculate the amount to send out:
Send := IF(Stores[CSum]>RELATED(Products[Need])+Stores[Units],
IF(Stores[CSum]<RELATED(Products[Need]),
Stores[Units],Stores[Units]-(Stores[CSum]-RELATED(Products[Need]))),0)
Needless to say, I'm getting #ERROR. I think the thought process works, but the formulas are wrong. Also, my Stores table has ~2M records with ~20k products, will I have any problem running this?
I thought of another solution -- Using VBA-code. First I want to give the whole code and then describe some problems:
Const maxStores = 16
Public i As Long
Public j As Integer
Public n As Integer
Public m As Long
Public rangeNeeds As Range
Public rangeHave As Range
Public rangeCost As Range
Sub transportation()
Dim Time1, Time2
Dim Txt As String
Txt = "Enter range with "
Set rangeNeeds = Application.InputBox(prompt:=Txt & "Needs", Type:=8)
Set rangeHave = Application.InputBox(prompt:=Txt & "Inventory", Type:=8)
Set rangeCost = Application.InputBox(prompt:=Txt & "Costs", Type:=8)
' find number of Stores
n = rangeCost.Rows.Count
If n <= maxStores Then
' Algorithm #1
'
'
' Step 1
' ------------------------------------------------------------------------
' make array of binary numbers & sort it
Time1 = Timer
' make array of indexes
Dim ArrIndex() As Long
ReDim ArrIndex(1 To n)
For j = 1 To n
ArrIndex(j) = rangeCost(j, 2)
Next j
' make Indexes
minCost = Application.WorksheetFunction.min(ArrIndex)
For j = 1 To n
If minCost = 0 Then
Debug.Print "Can't count Cost = 0"
Exit Sub
End If
ArrIndex(j) = ArrIndex(j) / minCost
Next j
' make array with indexes
' each index represents
' cost of transportanion
Dim Index As Long
Dim ll As Integer
Dim k, Temp
k = 2 ^ n - 1
ll = Len(k) + 1
Dim Arr()
ReDim Arr(1 To k)
For i = 1 To k
' count total index
For j = 1 To n
Index = Index + CInt(Mid(Dec2Bin(i, n), j, 1)) * ArrIndex(j)
Next j
Temp = Index * 10 ^ ll + i
Arr(i) = Temp
Index = 0
Next i
' sort Array
Call Countingsort(Arr)
' end of Step1
' ========================================================================
'
'
' Step2
' ------------------------------------------------------------------------
' Go throug each value and find the answer
Dim ProdNo As Long ' number of products in order
ProdNo = rangeNeeds.Rows.Count
Dim ArrHave() As Long
ReDim ArrHave(1 To ProdNo)
Dim rangeHaveProd As Range
Dim rangeHaveStor As Range
Dim rangeHaveQuan As Range
Set rangeHaveProd = rangeHave.Columns(1)
Set rangeHaveStor = rangeHave.Columns(2)
Set rangeHaveQuan = rangeHave.Columns(3)
For i = 1 To k ' All Binary Numbers
Temp = CInt(Right(Arr(i), ll - 1))
Temp = Dec2Bin(Temp, n)
' try fulfill the order
For j = 1 To n ' All Stores, n -- index of Store
Index = 0
Index = CInt(Mid(Temp, j, 1))
If Index = 1 Then 'If Store is On
For m = 1 To ProdNo ' All Products, m -- index of Product
ArrHave(m) = ArrHave(m) + _
WorksheetFunction.SumIfs( _
rangeHaveQuan, _
rangeHaveProd, rangeNeeds(m, 1), _
rangeHaveStor, rangeCost(j, 1))
Next m
End If
Next j
' Check if Needs meets
Dim CheckNeeds As Boolean
For m = 1 To ProdNo
If ArrHave(m) < rangeNeeds(m, 2) Then
CheckNeeds = False
Exit For
Else
CheckNeeds = True
End If
Next m
If CheckNeeds Then
Debug.Print "Answer is " & Temp
Exit For
Else
ReDim ArrHave(1 To ProdNo)
End If
Next i
' end of Step2
' ========================================================================
'
'
' Step3
' ------------------------------------------------------------------------
' make report
Sheets.Add
Dim Ws As Worksheet
Set Ws = ActiveSheet
With Range("A1")
.Value = "Report"
.Font.Size = 22
.Font.Bold = True
End With
Rows("4:4").Font.Bold = True
With Ws
' Stores table
.Range("G4") = "Store"
.Range("H4") = "Cost"
.Range("I4") = "On"
rangeCost.Copy
.Range("G5").PasteSpecial xlPasteValues
For i = 1 To n
.Range("I" & 4 + i) = Mid(Temp, i, 1)
Next i
' Needs table
.Range("K4") = "Product"
.Range("L4") = "Need"
rangeNeeds.Copy
.Range("K5").PasteSpecial xlPasteValues
' Have table
.Range("A4") = "Product"
.Range("B4") = "Store"
.Range("C4") = "Units"
.Range("D4") = "On"
.Range("E4") = "Send"
rangeHave.Copy
.Range("A5").PasteSpecial xlPasteValues
.Range("D5:D" & 4 + rangeHave.Rows.Count).FormulaR1C1 = _
"=VLOOKUP(RC[-2],C[3]:C[5],3,0)"
Dim QForm As String
QForm = "=IF(RC[-1]=0,0,IF(SUMIFS(C[7],C[6],"
QForm = QForm & "RC[-4])-SUMIFS(R4C5:R[-1]C,R4C1:R[-1]C[-4],"
QForm = QForm & "RC[-4])-RC[-2]>0,RC[-2],IF(SUMIFS(C[7],C[6],RC[-4])"
QForm = QForm & "-SUMIFS(R4C5:R[-1]C,R4C1:R[-1]C[-4],RC[-4])-RC[-2]<0,"
QForm = QForm & "SUMIFS(C[7],C[6],RC[-4])-SUMIFS(R4C5:R[-1]C,"
QForm = QForm & "R4C1:R[-1]C[-4],RC[-4]),RC[-2])))"
.Range("E5:E" & 4 + rangeHave.Rows.Count).FormulaR1C1 = QForm
Range("A2").FormulaR1C1 = "=""Total Cost = ""&INT(SUMIFS(C[7],C[8],1))"
Range("A2").Font.Italic = True
.Calculate
' convert formulas into values
.Range("D5:E" & 4 + rangeHave.Rows.Count) = .Range("D5:E" & 4 + rangeHave.Rows.Count).Value
End With
' end of Step3
' ========================================================================
'
Time2 = Timer
Debug.Print Format(Time2 - Time1, "00.00") & " sec."
Else
MsgBox "Number of stores exceeds Maximum. Need another Algorithm"
End If
End Sub
'Decimal To Binary
' =================
' Source: http://groups.google.ca/group/comp.lang.visual.basic/browse_thread/thread/28affecddaca98b4/979c5e918fad7e63
' Author: Randy Birch (MVP Visual Basic)
' NOTE: You can limit the size of the returned
' answer by specifying the number of bits
Function Dec2Bin(ByVal DecimalIn As Variant, _
Optional NumberOfBits As Variant) As String
Dec2Bin = ""
DecimalIn = Int(CDec(DecimalIn))
Do While DecimalIn <> 0
Dec2Bin = Format$(DecimalIn - 2 * Int(DecimalIn / 2)) & Dec2Bin
DecimalIn = Int(DecimalIn / 2)
Loop
If Not IsMissing(NumberOfBits) Then
If Len(Dec2Bin) > NumberOfBits Then
Dec2Bin = "Error - Number exceeds specified bit size"
Else
Dec2Bin = Right$(String$(NumberOfBits, _
"0") & Dec2Bin, NumberOfBits)
End If
End If
End Function
Sub Countingsort(list)
Dim counts()
Dim i
Dim j
Dim next_index
Dim min, max
Dim min_value As Variant, max_value As Variant
' Allocate the counts array. VBA automatically
' initialises all entries to 0.
min_value = Minimum(list)
max_value = Maximum(list)
min = LBound(list)
max = UBound(list)
ReDim counts(min_value To max_value)
' Count the values.
For i = min To max
counts(list(i)) = counts(list(i)) + 1
Next i
' Write the items back into the list array.
next_index = min
For i = min_value To max_value
For j = 1 To counts(i)
list(next_index) = i
next_index = next_index + 1
Next j
Next i
End Sub
Function Minimum(list)
Dim i As Long
Minimum = list(LBound(list))
For i = LBound(list) To UBound(list)
If list(i) < Minimum Then Minimum = list(i)
Next i
End Function
Function Maximum(list)
Dim i As Long
Maximum = list(LBound(list))
For i = LBound(list) To UBound(list)
If list(i) > Maximum Then Maximum = list(i)
Next i
End Function
First of all want to tell that task is very familiar to Transportation Problem. So I think of possible maths formulas which can find minimal Costs for transportation.
Problem #1. Big data
This solution goes straight through all combinations. It uses binary numbers to decide which store to select. For example, 01101 means try stores 2,3 and 5. This causes much trouble for computer to count each possibility. So I limited number of stores to 16.
Also I tried this code on 1000 products, not 20k. My computer can't solve this with 20k of products. So someone could make my code work faster.
=>
Problem #2. Costs
The third table is costs of transportation from each store. I added it to model:
| Store | Cost |
| 00001 | 5 |
| 00002 | 2 |
| 00003 | 1 |
| 00004 | 1 |
| 00005 | 10 |
So task is to find minimal transportation cost.
=>
Excel version
I used formula SUMIFS in my code. It will not work in Excel 2003.
=>
Conclusion
I believe this gives you some ideas and help someone else to develop the Code.
I have a table that looks like this:
| A | B | C | D |
+-------+------------+------------+------------+
1 | Name | Language 1 | Language 2 | Language 3 |
+=======+============+============+============+
2 | John | English | Chinese | Spanish |
3 | Wendy | Chinese | French | English |
4 | Peter | Spanish | Chinese | English |
And I want to generate a table that has only one language column. The other two language columns should become new rows like this:
| A | B |
+-------+----------+
1 | Name | Language |
+=======+==========+
2 | John | English |
3 | John | Chinese |
4 | John | Spanish |
5 | Wendy | Chinese |
6 | Wendy | French |
7 | Wendy | English |
8 | Peter | Spanish |
9 | Peter | Chinese |
10 | Peter | English |
I understand this will probably will need a macro or something. If anybody point me in the right direction it would me much appreciate. I am not very familiar with VBA or the Excel object model.
This will do the trick. It is also dynamic supports as many language columns as you want with as many languages per person.
Assumes the data is formatted as per the example:
Sub ShrinkTable()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = "Name"
.Cells(1, 2).Value = "Column"
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
'Name
.Cells(writeRow, 1).Value = data(row, 1)
'Language
.Cells(writeRow, 2).Value = data(row, col)
writeRow = writeRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub
Messy but should work:
For Each namething In Range("A1", Range("A1").End(xlDown))
Range("A1").End(xlDown).Offset(1, 0) = namething.Value
Range("A1").End(xlDown).Offset(0, 1) = namething.Offset(0, 2)
Range("A1").End(xlDown).Offset(1, 0) = namething.Value
Range("A1").End(xlDown).Offset(0, 1) = namething.Offset(0, 3)
namething.Offset(0, 2) = ""
namething.Offset(0, 3) = ""
Next
Then just sort
The following formula should work. The data in sheet2 would always reflect the data on sheet1 so you wouldn't have to re-run a macro to create a new list.
That being said, using a macro to generate it is probably a better choice as it would allow more flexability should you need to add a 4th language or something at a later date.
In Sheet2!A2
=INDIRECT("Sheet1!A"&ABS(INT((ROW()+1)/3))+1)
In Sheet2!B2
=INDIRECT("Sheet1!"&IF(ABS(INT((ROW()+1)/3)-(ROW()+1)/3)=0,"B",IF(ABS(INT((ROW()+1)/3)-(ROW()+1)/3)=(1/3),"C","D"))&ABS(INT((ROW()+1)/3))+1)
Add the column titles in A1 and B1 then autofill the formula down the sheet.