I have a several text separated by ;
A
1;2;3;5;6;7;8;9;10
11;12;13;14;15;16;17
18;19;20;21
Column A has few text in each row 1,2,3 and so on separated by ';'
With the help of 'Text to Column' Option in 'Data' tab we are able to separate the same
Which will look something like this
A B C D E F G H I
1 2 3 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21
Now we have to manually copy all text and shift the same to same column
A
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Numbers shown are already example, it can be any text string.
We are doing manually and it takes lot of time as there are more than 100's of entry.
Is there any way to automate the same with the help of macro? Have been googling and trying but not yet successful.
You can do this by some VBA source code:
Add a button on your sheet
Double click on it
Add the following code:
Private Sub CommandButton1_Click()
Dim Counter As Integer
Counter = 1
Dim curString As String
Dim whereComma As Integer
Dim i As Integer
For i = 1 To 10
curString = Cells(i, 1)
whereComma = InStr(1, curString, ";", vbTextCompare)
While InStr(whereComma, curString, ";", vbTextCompare) > 0
Cells(Counter, 4) = Left(curString, whereComma - 1)
Counter = Counter + 1
curString = Right(curString, Len(curString) - whereComma)
Wend
Cells(Counter, 4) = curString
Counter = Counter + 1
Next I
End Sub
End Sub
Click on button
You can see your result on column D
This VBA will do what you want and output to column B:
Sub TransposeColumnA()
Dim X As Long
For X = 1 To Range("A" & Rows.Count).End(xlUp).Row
Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1).Resize(UBound(Split(Range("A" & X).Text, ";")) + 1, 1).Formula = Application.Transpose(Split(Range("A" & X).Text, ";"))
Next
End Sub
Related
I'm trying to learn how to do count-sorting in excel-vba using arrays. I'm having some issue with the final step of actually doing the count sort (v1Sort and V2 Sort columns). This is the table so far
V1 V2 Bin V1Count PointerV1 V2Count PointerV2 V1Sort V2Sort
6 3 -1 2 2 1 1 ? ?
7 2 0 3 5 4 5
1 6 1 4 9 4 9
5 3 2 5 14 5 14
6 0 3 2 16 2 16
9 7 4 4 20 2 18
7 9 5 4 24 4 22
8 6 6 2 26 4 26
2 4 7 4 30 1 27
8 3 8 1 31 2 29
4 2 9 0 31 2 31
1 3 10
2 6
0 10
1 5
8 7
5 9
5 10
5 1
6 7
3 2
8 5
0 6
2 8
3 1
2 3
4 4
3 1
3 7
3 1
6 2
Here's my code so far without actually doing the final step of the count sort. I understand the concept fully but am finding it hard to use arrays to do the count sort.
Sub Count_Sorting()
Const iOffData As Integer = 1
Const iOffPoint As Integer = 2
Const iOffPoint_2 As Integer = 3
Dim iBin As Integer
Dim iData As Integer
Dim iPointerVector_1() As Integer
Dim iPointerVector_2() As Integer
Dim iPoint As Integer
Dim iRow As Integer
Dim iDataVector_1(32) As Integer
Dim iDataVector_2(32) As Integer
Dim iSortVector_1(1 To 50) As Integer
Dim iSortVector_2(1 To 50) As Integer
Application.ScreenUpdating = True
Sheets("Sheet1").Range(Cells(1, 3), Cells(50, 8)).Clear
ReDim iPointerVector_1(-1 To 11)
ReDim iPointerVector_2(-1 To 11)
Sheets("sheet1").Cells(1, 1).Value = "V1"
Sheets("sheet1").Cells(1, 2).Value = "V2"
Sheets("sheet1").Cells(1, 3).Value = "Bin"
Sheets("sheet1").Cells(1, 4).Value = "V1Count"
Sheets("sheet1").Cells(1, 5).Value = "PointerV1"
Sheets("sheet1").Cells(1, 6).Value = "V2Count"
Sheets("sheet1").Cells(1, 7).Value = "PointerV2"
'Write bin numbers.
For iRow = 2 To 13
Sheets("Sheet1").Cells(iRow, 3).Value = iRow - iOffPoint_2
Next iRow
'Read the values from Sheet1.
For iRow = 2 To 32
iDataVector_1(iRow) = Sheets("Sheet1").Cells(iRow, 1).Value
iDataVector_2(iRow) = Sheets("Sheet1").Cells(iRow, 2).Value
Next iRow
'************************************************************
'First we do the procedure for sorting Vector 1
'************************************************************
'Count the number of data points in each bin for Vector 1 .
For iRow = 2 To 32
iPointerVector_1(iDataVector_1(iRow)) = iPointerVector_1(iDataVector_1(iRow)) + 1
Next iRow
For iBin = 0 To 10
Sheets("Sheet1").Cells(iBin + iOffPoint, 4).Value = iPointerVector_1(iBin)
Next iBin
'Get cumulative counts, located in prior bins, in preparation for later
're-reading of the data and decrementing of the pointers for Vector 1.
For iBin = 0 To 10
iPointerVector_1(iBin) = iPointerVector_1(iBin - 1) + iPointerVector_1(iBin)
Next iBin
For iBin = 0 To 10
Sheets("SHeet1").Cells(iBin + iOffPoint, 5).Value = iPointerVector_1(iBin)
Next iBin
'
'************************************************************
'Now we do the procedure for sorting Vector 2
'************************************************************
'Count the number of data points in each bin for Vector 2.
For iRow = 2 To 32
iPointerVector_2(iDataVector_2(iRow)) = iPointerVector_2(iDataVector_2(iRow)) + 1
Next iRow
For iBin = 0 To 10
Sheets("SHeet1").Cells(iBin + iOffPoint, 6).Value = iPointerVector_2(iBin)
Next iBin
'Get cumulative counts, located in prior bins, in preparation for later
're-reading of the data and decrementing of the pointers for Vector 2.
For iBin = 0 To 10
iPointerVector_2(iBin) = iPointerVector_2(iBin - 1) + iPointerVector_2(iBin)
Next iBin
For iBin = 0 To 10
Sheets("SHeet1").Cells(iBin + iOffPoint, 7).Value = iPointerVector_2(iBin)
Next iBin
```End Sub
You indeed get the idea about count sorting. What makes your implementation difficult is the way you organize your code. Probably the first thing to do is to define a CountSort() function which takes as input an array of values, and returns an array of the same values sorted. Now, I see that you want to output the contents of intermediate arrays used in the count sort function to cells of Sheet1. So, you could pass to the CountSort() function the row and column indexes where to output intermediate arrays. So, your function could look like this:
' Returns array of the values sorted.
Public Function CountSort(values() As Integer, rowIndex As Integer, columnIndex As Integer) As Integer()
End Function
To output the contents of an array to Sheet1 you can define a routine like:
' Print contents of array values in column columnIndex, starting at rowIndex going downwards.
Sub PrintArray(values() As Integer, rowIndex As Integer, columnIndex As Integer)
Dim i As Integer
For i = 0 To UBound(values) - LBound(values)
Sheets("Sheet1").Cells(rowIndex + i, columnIndex).Value = values(LBound(values) + i)
Next
End Sub
And the CountSort() function would look like:
' Returns array of the values sorted.
Public Function CountSort(values() As Integer, rowIndex As Integer, columnIndex As Integer) As Integer()
' Assuming values are in range [0 10].
Dim bin(0 To 10) As Integer
Dim i As Integer
' Initialize bin to 0.
For i = LBound(bin) To UBound(bin)
bin(i) = 0
Next
PrintArray values, rowIndex, columnIndex
' Count number of occurrences of each value.
For i = LBound(values) To UBound(values)
bin(values(i)) = bin(values(i)) + 1
Next
PrintArray bin, rowIndex, columnIndex + 1
' Find cumulative frequency.
For i = LBound(bin) + 1 To UBound(bin)
bin(i) = bin(i) + bin(i - 1)
Next
PrintArray bin, rowIndex, columnIndex + 2
' Build sorted array.
Dim sorted() As Integer
ReDim sorted(LBound(values) To UBound(values)) As Integer
For i = UBound(values) To LBound(values) Step -1
sorted(bin(values(i))) = values(i)
bin(values(i)) = bin(values(i)) - 1
Next
PrintArray sorted, rowIndex, columnIndex + 3
' Return sorted array.
CountSort = sorted
End Function
In VBA, it is always a good idea to use the LBound() and UBound() functions as they make your code independent of how arrays have been declared index-wise.
I have this excel file in Sheet1:
A B C D
Brand Model Type No_of_unit_sold
A AB123 1 1
A AB124 1 2
A AB125 1 11
A AB113 1 21
A AB127 1 42
A AB128 1 12
B BB123 1 21
B BB121 1 32
AB BB122 2 21
AB BB124 1 79
AB BB125 2 61
AB BB126 1 181
B BB127 1 28
B BB128 1 132
C CB121 1 91
C CB122 1 73
C CB123 1 63
C CB124 1 52
C CB125 1 85
A AB129 2 12
C CB126 1 13
C CB128 1 94
C CB129 1 121
I need the VBA to first scan column "Type" for type 1 only.
and then, to look for brand, copy brand A's name, sum up the number of unit sold and paste it in Sheet2:
A B C D E
Brand A B AB C
No_of_unit_sold 89 213 260 592
To sum up the value, I can use sumif function with double criteria. But how do I vary the name of the brand? It's not like using for loop with integer like what I can do for "Type" column...
Also, how do I copy brand name from sheet1 to sheet2 without duplication?
Do I use application.worksheetfunction.match? Eg. if the brand name is not found in cells(1,i) of sheet2 then please copy from sheet1 to sheet2?
Below code will works for you. I have used couple of For loops, If statement and Function to achieve this as am not knowledgeable with application.worksheetfunction.match. I tried as below and Worked for me!
Input sheet:
Try the below code.
Sub VBAReader()
Dim CompareBrand As String
'Dim CompareBrands() As Variant
Dim Types, units, Units_sold, ValidatedBrands As Integer
Units_sold = 0
Dim Brand As String
Dim i, j, k, l As Integer
k = 2
Types = Worksheets("Sheet1").Range("C2").End(xlDown).Row
For i = 2 To Types
'Give the type of value
If Worksheets("Sheet1").Range("C" & i).Value = 1 Then
Brand = Worksheets("Sheet1").Range("A" & i).Value
If BrandIsValidated(Brand) = False Then
For j = 2 To Types
If Worksheets("Sheet1").Range("A" & j).Value = Brand And Worksheets("Sheet1").Range("C" & j).Value = 1 Then
units = Worksheets("Sheet1").Range("D" & j).Value
Units_sold = Units_sold + units
End If
Next
Worksheets("Sheet2").Cells(1, k).Value = Brand
Worksheets("Sheet2").Cells(2, k).Value = Units_sold
Units_sold = 0
CompareBrand = Worksheets("Sheet2").Cells(1, k).Value
k = k + 1
End If
End If
Next
End Sub
Function BrandIsValidated(stringToBeFound As String) As Boolean
ValidatedBrands = Worksheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column
For l = 1 To ValidatedBrands
If stringToBeFound = Worksheets("Sheet2").Cells(1, (l + 1)).Value Then
BrandIsValidated = True
Exit For
Else
BrandIsValidated = False
End If
Next
End Function
Output sheet:
Note: I am new to VBA so my code wont be friendly. Edits are welcome :)
I have an excel 2007 sheet where column names with data are all placed in one single column and I need to shift one column name to the left or right with data so that I can have separate columns. Can you create a VBA function where it reads all rows of the column and shift those columns with certain keywords. Such as:
A1 B1
1 **Category1**
Cat1 info here
**cf**
45
34
34
Sf
542
234
234
2 **Category2**
Cat2 info here
**cf**
76
23
67
**Sf**
678
987
3476
I Need to move "cf" column + data to a different column and paste it to its relevant category. So "cf" would shift right with data and move up along with its category. I would then delete the empty rows of B Column.
Finally had it figured out, Bad coding maybe but it works.. :)
Thanks All for your Help .
Sub test()
Dim i As Long
Dim toprow As Long
Dim z As Long
Dim count As Long
Dim b As Long
toprow = 3
b = toprow
For i = toprow To Cells(Rows.count, 1).End(xlUp).Row
If Not Cells(i, 1) = "" And Not Cells(i, 2) = "" Then
b = i
count = 0
z = i
End If
If Cells(i, 1) = "" Then
If Cells(i + 1, 1) = "" Then
z = i
If Not Cells(z + 1, 2) = "" Then
Cells(z + 1, 2).Cut Cells(b, 2)
i = b
b = z + 1
count = 0
ElseIf count = 0 Then
count = z
b = count
End If
End If
End If
Next i
End Sub
I need to shift all data in a row out like this:
Qty Shift Hr 1 Hr 2 Hr 3 Hr 4 Hr 5 Hr 6
1 0 1 1 1
2.2 3 2.2 2.2 2.2
I have a lot of rows and they can be across even a few hundred columns.. hence the help. Thanks
If I understood your question correctly you need:
Sub ShiftData()
Dim ActiveRow As Range
Dim InputData As Range
Set InputData = Range(Range("A2"), Range("A2").End(xlDown))
For Each ActiveRow In InputData.Rows
'Paste contents starting column C(3)
Cells(ActiveRow.Row, 3 + ActiveRow.Offset(0, 1).Value + 0).Value = ActiveRow.Value
Cells(ActiveRow.Row, 3 + ActiveRow.Offset(0, 1).Value + 1).Value = ActiveRow.Value
Cells(ActiveRow.Row, 3 + ActiveRow.Offset(0, 1).Value + 2).Value = ActiveRow.Value
Next
End Sub
I have a question about Excel.
I have a sheet with some columns, like:
A B C
------------------------
1 test 1
2 test 5
3 test 5
4 test 2
4 test 6
5 test 7
6 test 8
7 test 2
8 test 3
9 test 3
9 test 1
9 test 4
10 test 5
I would like a macro that does the following. It checks C. If value of C is lower than 3, copy that row and all the following rows with the same value in A, until A changes, to a new sheet, Then check C again and so on.
Output here should be:
A new sheet with
a b c
4 test 2
4 test 6
7 test 2
9 test 1
9 test 4
Can anyone please help me with that?
Think I've found it (haven t really tested it yet)
Sub CustomcCopy()
Dim controleValue As Double
controleValue = 3
Dim AValue As String
Dim lastline As Integer, tocopy As Integer
lastline = Range("F65536").End(xlUp).Row
j = 1
For i = 1 To lastline
For Each c In Range("L" & i)
If (c < controleValue And c > 0) Then
tocopy = 1
End If
Next c
If tocopy = 1 Then
AValue = Cells(i, "A").Value
Do While Cells(i, "A").Value = AValue
Rows(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
i = i + 1
Loop
End If
tocopy = 0
Next i
End Sub