I have about 1000 unique rows with columns to be split. I am new to VBA and not sure how to split multiple columns into rows with holding ID. The number of elements in a column can varies between rows but is the same across columns in the same row .
Input:
+----+---------------+----------+----------+
| id | col1 | col2 | col3 |
+----+---------------+----------+----------+
| 1 | abc, bcd, cde | aa,bb,cc | 1a,2b,3a |
| 2 | abc, ded | ba,de | a7,7a |
| 3 | a,b,c,d | d,c,d,a | f,d,s,a |
+----+---------------+----------+----------+
Output:
+----+------+------+------+
| id | col1 | col2 | col3 |
+----+------+------+------+
| 1 | abc | aa | 1a |
| 1 | bcd | bb | 2b |
| 1 | cde | cc | 3a |
| 2 | abc | ba | a7 |
| 2 | ded | de | 7a |
| 3 | a | d | f |
| 3 | b | c | d |
| 3 | c | d | s |
| 3 | d | a | a |
+----+------+------+------+
Your help will be greatly appreciated!
I don't know why "VBA: Split cell values into multiple rows and keep other data" this link as a previous answer but I think splitting one column and multiple columns are different questions.
Try this code (comments in code):
Sub Expand()
Dim currentRow As Long, lastRow As Long, table As Variant, i As Long, _
valuesInOneRowCol1 As Variant, valuesInOneRowCol2 As Variant, valuesInOneRowCol3 As Variant
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
currentRow = 2
'read hwole range to memory and clear the range to fill it with expanded data
table = Range("A2:D" & lastRow).Value2
Range("A2:D" & lastRow).Clear
For i = 1 To lastRow - 1
'split comma separated lists in each column
valuesInOneRowCol1 = Split(table(i, 2), ",")
valuesInOneRowCol2 = Split(table(i, 3), ",")
valuesInOneRowCol3 = Split(table(i, 4), ",")
'write all data from one row
For j = LBound(valuesInOneRowCol1) To UBound(valuesInOneRowCol1)
Cells(currentRow, 1) = table(i, 1)
Cells(currentRow, 2) = valuesInOneRowCol1(j)
Cells(currentRow, 3) = valuesInOneRowCol2(j)
Cells(currentRow, 4) = valuesInOneRowCol3(j)
currentRow = currentRow + 1
Next
Next
End Sub
Related
My spreadsheet continuously refreshes data contained in the table based on a project number. There are 5 additional columns that contain manually inputted information (i.e. does not automatically refresh) associated with each project number. These columns essentially contain user comments and must stay associated with the project number through each refresh. When a refresh occurs, new project numbers may also be added to the list.
I am looking for a solution to store these 5 manually inputted columns with the project number.
Previously, we used a dictionary when only one key-value pairing was required. However, now we have multiple values for each key.
Public Function saveComments(rowOfCom As Integer, _
rowOfSafety As Integer, _
rowOfCompliance As Integer, _
rowOfCommercial As Integer, _
rowOfOperational As Integer, _
rowOfSIssue As Integer, _
ws As Worksheet) As Variant
'Sub is meant to save comments associated with masterplan id's
'We do this by first making one dictionary with every plan year and another
' dictionary that will store the mpids & comments
'Idea is to loop through each ws, store each mpid and comment then run macro
' to update mpids then paste in new comments
Dim mpDict As New Scripting.Dictionary
Dim numOfWS As Integer, count As Integer, rowCount As Integer, i As Integer
Dim rg As Range
Dim Key As Variant
Dim value As Variant
'Get the number of mpDictionaries needed. Counts the sheets if its a year
' or Not set just in case a sheet is added
With ws
rowCount = .Range("A1").End(xlDown).Row
For i = 2 To rowCount
If mpDict.Exists(.Cells(i, 1).value) = False Then
For j = 13 To j = 18
'Access the mpDict and store the MPID and Comment
mpDict.Add .Cells(i, 1).value, .Cells(i, j).value
Next j
End If
Next i
' Debug.Print (yearDict.Item(ws.Name).Item(.Cells(2, 1).value))
count = count + 1
End With
Set saveComments = mpDict
End Function
What I do in this case is to build a compound entry for each key. This can be in the form of a Class object, another Dictionary, a Collection or almost anything. For the simplest of situations though, I just create a CSV list.
For example, if my data is
+--------+----+
| red | 42 |
| green | 36 |
| blue | 49 |
| white | 44 |
| orange | 25 |
| black | 45 |
| purple | 32 |
| mauve | 41 |
| cherry | 14 |
| lemon | 32 |
| lime | 6 |
| red | 11 |
| green | 17 |
| blue | 13 |
| white | 9 |
| orange | 23 |
| black | 21 |
| purple | 38 |
| mauve | 19 |
| cherry | 22 |
| lemon | 42 |
| lime | 48 |
| red | 35 |
| green | 37 |
| blue | 44 |
| white | 6 |
| orange | 41 |
| black | 5 |
| purple | 15 |
| mauve | 20 |
+--------+----+
Then I'll build a using code similar to
Option Explicit
Sub BuildDictionaryExample()
Dim myDict As Dictionary
Set myDict = New Dictionary
Dim myData As Range
Set myData = Sheet1.Range("A1:B30")
Dim keyValue As Variant
Dim thisRow As Range
For Each thisRow In myData.Rows
keyValue = thisRow.Cells(1, 1)
If Not myDict.Exists(keyValue) Then
myDict.Add keyValue, thisRow.Cells(1, 2)
Else
Dim newValue As Variant
newValue = myDict(keyValue) & "," & thisRow.Cells(1, 2)
myDict(keyValue) = newValue
End If
Next thisRow
End Sub
This is a follow up to my previous question (Retrieving information of OLEObjects from Workbook with VBA)
Scenario: I am trying to retrieve data from a worksheet. The data might be normal strings or number or might be encased in check boxed (checked or not).
Data example:
+---------+-------+------------------+------+------------------+
| item1 | 2004 | | | |
+---------+-------+------------------+------+------------------+
| value x | rfd | checkbox for rfd | nfd | checkbox for nfd |
+---------+-------+------------------+------+------------------+
| ident | test7 | call3 | | |
+---------+-------+------------------+------+------------------+
Obs: In this example the "checkbox for rfd/nfd" is a normal checkbox (either form or activex), and depending on the item in that sheet, either might be selected.
Objective: What I am trying to do is read the worksheet in 2 steps: First read all the data that is directly called, so I use the code:
Sub Test_retrieve()
' this will get all non object values from the sheet
Dim array_test As Variant
Dim i As Long, j As Long
array_test = ThisWorkbook.Sheets(1).UsedRange
For i = 1 To ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To ThisWorkbook.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
ThisWorkbook.Sheets(2).Cells(i, j) = array_test(i, j)
Next j
Next i
End Sub
to get:
+---------+-------+------------------+------+------------------+
| item1 | 2004 | | | |
+---------+-------+------------------+------+------------------+
| value x | rfd | | nfd | |
+---------+-------+------------------+------+------------------+
| ident | test7 | call3 | | |
+---------+-------+------------------+------+------------------+
Next I am trying to reach all the objectives/shapes in my worksheet. I used the following code to get name, value (checked of not) and location of all activex objects:
Sub getavticeboxvalue()
' this will get the names and values (as binary) of all the activex controlbox objects in the sheet
Dim objx As Object
Dim i As Long
i = 1
For Each objx In ThisWorkbook.Sheets(1).OLEObjects
If objx.Object.Value = True Then
ThisWorkbook.Sheets(3).Cells(i, 1).Value = 1
ThisWorkbook.Sheets(3).Cells(i, 2).Value = objx.Name
ThisWorkbook.Sheets(3).Cells(i, 3).Value = objx.BottomRightCell.Address
ElseIf objx.Object.Value = False Then
ThisWorkbook.Sheets(3).Cells(i, 1).Value = 0
ThisWorkbook.Sheets(3).Cells(i, 2).Value = objx.Name
ThisWorkbook.Sheets(3).Cells(i, 3).Value = objx.BottomRightCell.Address
End If
i = i + 1
Next objx
End Sub
Which yields something like:
+-------+-----------+----------+
| value | name | location |
+-------+-----------+----------+
| 0 | checkbox1 | $C$2 |
+-------+-----------+----------+
| 1 | checkbox2 | $E$2 |
+-------+-----------+----------+
I would then proceed to feed the values (1s and 0s), to the first table, in the place where the checkboxes originally where (location).
Issue: When I try the same procedure for Form Control (instead of activex), I have less options, and although I can look for them (ThisWorkbook.Sheets(1).Shapes.Type = 8) I cannot find their name or location.
Question: Is there a way to find their name and location? Is there a more efficient way to reach the result?
Objective:
+---------+-------+------------------+
| item1 | 2004 | | | |
+---------+-------+------------------+
| value x | rfd | 0 | nfd | 1 |
+---------+-------+------------------+
| ident | test7 | call3 | | |
+---------+-------+------------------+
I have values in cell like.
1,2,4,45,64,Jan. Ans: 5
I want to count only number from the cell.
Is it possible?
You could also use the split function in a UDF:
Function CountNumbers(R As Range) As Integer
Dim values, value As Variant
Dim result As Integer
values = Split(R.Text, ",")
result = 0
For Each value In values
If IsNumeric(value) Then
result = result + 1
End If
Next value
CountNumbers = result
End Function
From here, you could call it within another Excel cell as:
=CountNumbers(A1)
Here is my answer:
Sub countingNumbers()
Dim c As Range
Dim L As Long
Dim s As String
Dim tmp
Dim i
Dim y
Set c = Range("A1") 'Imagine in A1 is this: "RDFY2372784GDTD2GV3G3G3V3"
L = Len(c.Value) 'to store the len of the string
s = c.Value 'to store the string
y = 0 'the index of the numbers
For i = 1 To L
tmp = Left(Right(s, i), 1) 'to take just one letter at the time
If Asc(tmp) < 57 And Asc(tmp) > 48 Then
'if is a number ASC() returns the ASCII code of that number
'and increase y one by one || that is number by number
y = y + 1
End If
Next i
Range("B2").Value = y 'store the counting in B2
End Sub
Part of the ASCII Table:
+------------+-----------+
| ASCII Code | Character |
+------------+-----------+
| 48 | 0 |
| 49 | 1 |
| 50 | 2 |
| 51 | 3 |
| 52 | 4 |
| 53 | 5 |
| 54 | 6 |
| 55 | 7 |
| 56 | 8 |
| 57 | 9 |
| 64 | # |
| 65 | A |
| 66 | B |
| 67 | C |
| 68 | D |
| 69 | E |
| 70 | F |
| 71 | G |
| 72 | H |
| 73 | I |
| 74 | J |
+------------+-----------+
Here you can check the ASCII table
I have a spreadsheet that has column E that requires values split (comma separated values currently) and transposed to multiple rows. Columns C, D, F-S need copied down. Example:
Columns
+-----+-------+------------------+-------+--------+--------+----------+
| C | D | E | F | G | H | ... S |
+-----+-------+------------------+-------+--------+--------+----------+
| 20 | hey | one, two, three | xyz | unit | right | ... end |
+-----+-------+------------------+-------+--------+--------+----------+
I need it to look like:
+-----+-------+--------+-------+--------+--------+---------+
| C | D | E | F | G | H | ... S |
+-----+-------+--------+-------+--------+--------+---------+
| 20 | hey | one | xyz | unit | right | ... end |
| 20 | hey | two | xyz | unit | right | ... end |
| 20 | hey | three | xyz | unit | right | ... end |
+-----+-------+--------+-------+--------+--------+---------+
any help would be great!
This Code should help you...
Sub GetOutput()
Dim rndData As Range
Dim rngOutCell As Range
Dim MainIindex As Integer '<< Column index Needs to be split
Dim AllData As Variant '<< Data Range
Dim InnerData As Variant '<< Split Data
Dim intRecordCounter As Integer
MainIindex = 3
lngDataRow = 0
Set rndData = Sheet1.Range("E1").CurrentRegion
Set rngOutCell = Sheet1.Range("O1")
For intRecordCounter = 1 To rndData.Rows.Count
AllData = rndData.Rows(intRecordCounter).Value
InnerData = Split(rndData.Rows(intRecordCounter).Cells(MainIindex).Value, ",")
Set rngOutCell = Sheet1.Cells(Rows.Count, rngOutCell.Column).End(xlUp)
If rngOutCell <> vbNullString Then
Set rngOutCell = rngOutCell.Offset(1)
End If
Set rngOutCell = rngOutCell.Resize(UBound(InnerData) + 1, UBound(AllData, 2))
rngOutCell.Value = AllData
rngOutCell.Offset(, MainIindex - 1).Resize(, 1).Value = Application.Transpose(InnerData)
Next intRecordCounter
ClearMemory:
MainIindex = Empty
If IsArray(AllData) Then Erase AllData
If IsArray(InnerData) Then Erase InnerData
intRecordCounter = Empty
Set rndData = Nothing
Set rngOutCell = Nothing
End Sub
I have simple list:
A B
item1 3
item2 2
item3 4
item4 1
Need to output:
A
item1
item1
item1
item2
item2
item3
item3
item3
item3
item4
Here is one way of doing it without VBA:
Insert a column to the left of A, so your current A and B columns are now B and C.
Put 1 in A1
Put =A1+C1 in A2 and copy down to A5
Put an empty string in B5, by just entering a single quote (') in the cell
Put a 1 in E1, a 2 in E2, and copy down as to get 1, 2, ..., 10
Put =VLOOKUP(E1,$A$1:$B$5,2) in F1 and copy down.
It should look like this:
| A | B | C | D | E | F |
|----|-------|---|---|----|-------|
| 1 | item1 | 3 | | 1 | item1 |
| 4 | item2 | 2 | | 2 | item1 |
| 6 | item3 | 4 | | 3 | item1 |
| 10 | item4 | 1 | | 4 | item2 |
| 11 | | | | 5 | item2 |
| | | | | 6 | item3 |
| | | | | 7 | item3 |
| | | | | 8 | item3 |
| | | | | 9 | item3 |
| | | | | 10 | item4 |
Here's the VBA solution. I don't quite understand the comment that VBA won't be dynamic. It's as dynamic as you make it, just like a formula. Note that this macro will erase all data on Sheet1 and replace it with the new output. If you want the desired output on a different sheet, then change the reference to Sheet2 or what have you.
Option Explicit
Sub MultiCopy()
Dim arr As Variant
Dim r As Range
Dim i As Long
Dim currRow As Long
Dim nCopy As Long
Dim item As String
'store cell values in array
arr = Sheet1.UsedRange
currRow = 2
'remove all values
Sheet1.Cells.ClearContents
Sheet1.Range("A1") = "A"
For i = 2 To UBound(arr, 1)
item = arr(i, 1)
nCopy = arr(i, 2) - 1
If nCopy > -1 Then
Sheet1.Range("A" & currRow & ":A" & (currRow + nCopy)).Value = item
currRow = currRow + nCopy + 1
End If
Next
End Sub