I am slowly learning how to do some very basic routines in Excel VBA, but I dont know how to tackle this one.
How can I go from data in one row looking like this :
11-Jun,27.3,28.3,12-Jun,27.2,28.3,13-Jun,26.7,28.4,14-Jun,26.7,28.4
to 3 columns.
First column with date, 2nd with first value, 3rd with the second value ?
Thanks
Put your data in A1.
This will loop the data back to the desired column based on if there is a remainder left after dividing.
Option Explicit
Sub splitData()
Dim i, rownum, colnum As Integer
Dim str As Variant
colnum = 1
rownum = 2
str = Split(Cells(1, 1).Value, ",")
For i = 0 To UBound(str)
If i Mod 3 = 2 Then
Cells(rownum, 3).Value = "'" & str(i)
End If
If i Mod 3 = 1 Then
Cells(rownum, 2).Value = "'" & str(i)
End If
If i Mod 3 = 0 Then
rownum = rownum + 1
Cells(rownum, 1).Value = "'" & str(i)
End If
Next i
End Sub
Or maybe something like this :
Sub test()
x = Split(Range("A1"), ",")
y = (UBound(x) + 1) / 3
P = 1
For i = 1 To y
For Z = 1 To 3
Cells(i + 3, Z).Value = x(P - 1)
P = P + 1
Next
Next
End Sub
Related
I am attempting to loop through a column. If the the item in the column matches the next item in the column. If they are the same, I will take values associated with the first row item and append it with stuff from the lines below.
I have tried using nested if loops to loop through a column. Ignore some of the functionality my code, but I am not sure why my comparisons are not working.
For bigLoop = 1 To Length + 1
firstString = Workbooks("VBA_Basics.xlsm").Worksheets("TestSheet").Cells(bigLoop, 24).Value
Cells(bigLoop, 28).Value = Cells(bigLoop, 26)
Debug.Print firstString
For smallLoop = 1 To Length + 1
secondString = Workbooks("VBA_Basics.xlsm").Worksheets("TestSheet").Cells(smallLoop + 1, 4).Value
Debug.Print secondString
myComp = StrComp(firstString, secondString, vbBinaryCompare)
If myComp = 0 Then
Cells(bigLoop, 28).Value = Cells(bigLoop, 26).Value & " :) " & Cells(smallLoop + 1, 26).Value
End If
Debug.Print myComp
Next smallLoop
Next bigLoop
Please sort your column! Then try this:
Option Explicit
Option Base 1
Private Const NITEMS As Integer = 11
' Column "A"
Private Const COLUMN As Integer = 1
' Column "B"
Private Const TARGET_COLUMN As Integer = 2
' Please sort your column!
Public Sub X()
Dim I As Integer
Dim J As Integer
Dim V1 As Variant
Dim V2 As Variant
I = 1
While I <= NITEMS
V1 = ActiveSheet.Cells(I, COLUMN).Value
ActiveSheet.Cells(I, TARGET_COLUMN).Value = V1
J = I + 1
V2 = ActiveSheet.Cells(J, COLUMN).Value
While V1 = V2 And J <= NITEMS
ActiveSheet.Cells(I, TARGET_COLUMN).Value = _
ActiveSheet.Cells(I, TARGET_COLUMN).Value & " :) " & V2
J = J + 1
V2 = ActiveSheet.Cells(J, COLUMN).Value
Wend
I = J
Wend
End Sub
I have this code that looks at column A and loops through to create an array to paste to another destination, but I want to manipulate it to loop through sets of 250 cells and create a concatenated array and print it to cells B1. After that set of 250, I go cells a251-a501, and so forth until I reach the end of the list and have each set of 250 concatenated ID's (separated by a ";") to print to the next destination row (B1>B2>B3, etc..)
Sub JC_Fill()
Dim varArray() As Variant
Dim x As Long, i As Long
i = 0
x = 1
With ThisWorkbook.Worksheets("Sheet1").UsedRange.Rows.Count
ReDim varArray(1) 'resize array
Do Until Cells(x, 1).Value = ""
If Cells(x, 1) <> "" Then
varArray(i) = Cells(x, 1).Value
i = i + 1
ReDim Preserve varArray(i)
End If
x = x + 1
Loop
ReDim Preserve varArray(i - 1)
End With
ThisWorkbook.Worksheets("Sheet1").Range("B1").Value = varArray
End Sub
How could I edit my Do While/Loop to repeat the process every 250 cells and then concatenate the array to one cell separated by ; and then offset the next batch until I have no more ID's to cycle through?
Try changing your code this way:
Sub JC_Fill()
Dim OutString
Dim x As Long, i As Long
Dim out_row As Long
i = 0
x = 1
out_row = 1
With ThisWorkbook.Worksheets("Sheet1").UsedRange.Rows.Count
OutString = ""
Do Until Cells(x, 1).Value = ""
If Cells(x, 1) <> "" Then
If (x > 1) Then OutString = OutString & ";"
OutString = OutString & Cells(x, 1).Value
End If
If (x Mod 250) = 0 Then
ThisWorkbook.Worksheets("Sheet1").Range("B" & out_row).Value = OutString
OutString = ""
out_row = out_row + 1
End If
x = x + 1
Loop
End With
ThisWorkbook.Worksheets("Sheet1").Range("B" & out_row).Value = OutString
End Sub
For interest, you can do this without looping each of the 250 cells.
Sub x()
Dim n As Long, v As Variant, r As Range, n2 As Long
n = 5 '250 for you
n2 = Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("A1").Resize(n)
Do While Len(r(1)) > 0
If n2 - r(1).Row < n Then Set r = r.Resize(n2 - r(1).Row + 1)
If r.Count = 1 Then
v = r.Value
Else
v = Join(Application.Transpose(r), ";")
End If
Range("B" & Rows.Count).End(xlUp)(2).Value = v
Set r = r.Offset(n)
Loop
End Sub
I have challenges in highlighting/copying alternate rows in one column and pasting it to the next column and aligned.
Here's a screenshot:
Following code assumes you have two separate tabs, SRC and DST and the range of data starts in the first cell. Will do all in a single step:
Public Sub CopyAlternate()
Dim i As Long
i = 2
While Len(Sheets("SRC").Cells(i, 1).Value) > 0
Sheets("DST").Cells(i / 2 + 1, 1).Value = Sheets("SRC").Cells(i, 1).Value
Sheets("DST").Cells(i / 2 + 1, 2).Value = Sheets("SRC").Cells(i + 1, 1).Value
i = i + 2
Wend
End Sub
You can take this code and adjust it to taste:
Sub alternate()
Dim i As Integer
Dim j As Integer
Dim n As Integer
i = 0
j = 0
n = 0
With ActiveSheet
For Each c In .Range("A4:A16")
.Cells(20 + j, 1 + i).Value = c.Value
If n = 0 Or n Mod 2 = 0 Then
i = 1
j = j
Else
i = 0
j = j + 1
End If
n = n + 1
Next c
End With
End Sub
This worked for me when rebuilding your example with letters (for faster checking).
I have a file with 3 main names in a column.
Names
------
George
John
Victor
below the names at column A I have 3 categories
food
drink
super
at the right of the file i have data 1 + 2 + 3
note that the 3 categories are not in the same order all the time.
What is the best way to retrieve data point 3 for each name with category drink and food only in another cell?
Thanks
Edit: Ok, now I understand the full extent of your problem, the below code will actually do what you require. In future, try and explain the limits of variables that you need to process, and the limits or constraints that you need to work to.
Noting your pasted copy of your workbook, the following should work:
Sub Get_Third_Value()
Dim Totals() As Variant, Names() As String, Cats() As String
Dim X As Integer, Cur_Pers As Integer, Y As Integer, Z As Integer, No_Cats As Integer, No_Ppl As Integer, Last_Row As Integer
Dim Tmp_Val As String
ReDim Totals(1 To 7, 1 To 1) As Variant
ReDim Names(1 To 1) As String
ReDim Cats(1 To 1) As String
Dim Data As Variant
Do
'This lets the user determine which data column they wish to total.
Data = -1
Data = InputBox("Please state which Data Value you wish to total:", "Total which Data:", "3")
If IsNumeric(Data) = False Then Data = -1
Loop Until Data > 0 And Data < 4
For X = 2 To 10000
'This for loop is used to generate a list of People's Names and the Categories of data (E.G. Food, Drink, Super, etc).
'There is an assumption that there will only be a maximum of 7 Categories.
If Range("A" & X).Value = "" Then
'This ensures that at the end of the list of data the process ends.
Last_Row = X - 1
Exit For
End If
Tmp_Val = LCase(Range("A" & X).Value)
If No_Cats <> 0 Then
For Y = 1 To No_Cats
If Tmp_Val = Cats(Y) Then GoTo Already_Added 'This checks the array of Categories and skips the remainder if this already exists in that array.
Next Y
End If
For Y = (X + 1) To 10000
If Range("A" & Y).Value = "" Then GoTo Add_Name 'If the value is not repeated in the list, it must be someone's name.
If Tmp_Val = LCase(Range("A" & Y).Value) Then
'If the value is repeated in the list in Column A, it must be a Category of data.
If No_Cats = 0 Then
'When no Categories have been added to the array of Categories, then the first is just added.
No_Cats = 1
ReDim Preserve Cats(1 To No_Cats) As String
Cats(No_Cats) = Tmp_Val
Else
'If the Category wasn't already found in the array of Categories, then this adds it.
No_Cats = No_Cats + 1
ReDim Preserve Cats(1 To No_Cats) As String
Cats(No_Cats) = Tmp_Val
Dont_Add_Cat:
End If
'Once the category has been added, then you don't need to keep checking the list.
GoTo Already_Added
End If
Next Y
Add_Name:
No_Ppl = No_Ppl + 1
ReDim Preserve Names(1 To No_Ppl) As String
ReDim Preserve Totals(1 To 7, 1 To No_Ppl) As Variant
Names(No_Ppl) = Tmp_Val
Already_Added:
Next X
For X = 2 To Last_Row
For Y = 1 To No_Ppl
'This for loop checks the current row against the list of names.
If LCase(Range("A" & X).Value) = Names(Y) Then
Cur_Pers = Y
Exit For
End If
Next Y
For Y = 1 To No_Cats
'This for loop checks the current row against the array of Categories and increments the total as required.
If LCase(Range("A" & X).Value) = Cats(Y) Then
Totals(Y, Cur_Pers) = Totals(Y, Cur_Pers) + CInt(Range(Cells(X, Data + 1).Address).Value)
Exit For
End If
Next Y
Next X
With Range(Cells(Last_Row + 2, 3).Address & ":" & Cells(Last_Row + 2, 2 + No_Cats).Address)
.Merge
.Value = "Data " & Data
.HorizontalAlignment = xlCenter
End With
For X = 1 To No_Ppl
Range("B" & X + (Last_Row + 4)).Value = UCase(Left(Names(X), 1)) & Right(Names(X), Len(Names(X)) - 1)
Next X
For Y = 1 To No_Cats
Range(Cells(Last_Row + 3, 2 + Y).Address).Value = "Sum of " & Cats(Y)
Range(Cells(Last_Row + 4, 2 + Y).Address).Value = Cats(Y)
For X = 1 To No_Ppl
Range(Cells(Last_Row + 4 + X, 2 + Y).Address).Value = Totals(Y, X)
Next X
Next Y
End Sub
I have data which goes down a column (A:A) (see example).
The only possible values [in this case] are: 1,2,3,4,5,s,f and p,o,a,b,c, (which aren't needed in this case and can be deleted)
1-
2-
s
1
2
3
2
f
s
f
1
s
4
5
3
4
2
s
f
1
2
3
4
I need some code that will count the frequencies of numbers after certain letters have occured. In this case, i want the code to count the numbers after S or F. I have put in bold the numbers after S and in italics the numbers after F. The two numbers at the start can be ignored since no letter precedes them.
I would then need 10 different output variables
After S:
Frequency of 1:## Frequency of 2:## Frequency of 3:## Frequency of 4:## Frequency of 5:##
After F:
Frequency of 1:## Frequency of 2:## Frequency of 3:## Frequency of 4:## Frequency of 5:##
Im assuming the .countif would come in handy, have no idea to make this work though.
Is this what you are looking for? There are other ways to accomplish this as well. Let me know if you have any questions about what I did.
Private Sub CommandButton1_Click()
Dim sOne As Integer
Dim sTwo As Integer
Dim sThree As Integer
Dim sFour As Integer
Dim sFive As Integer
Dim fOne As Integer
Dim fTwo As Integer
Dim fThree As Integer
Dim fFour As Integer
Dim fFive As Integer
Dim lastRow As Integer
lastRow = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
For rows1 = 1 To lastRow
If ThisWorkbook.Sheets(1).Range("A" & rows1) = "s" Then
Do While WorksheetFunction.IsNumber(ThisWorkbook.Sheets(1).Range("A" & rows1 + 1))
If ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 1 Then
sOne = sOne + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 2 Then
sTwo = sTwo + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 3 Then
sThree = sThree + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 4 Then
sFour = sFour + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 5 Then
sFive = sFive + 1
End If
rows1 = rows1 + 1
Loop
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1) = "f" Then
Do While WorksheetFunction.IsNumber(ThisWorkbook.Sheets(1).Range("A" & rows1 + 1))
If ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 1 Then
fOne = fOne + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 2 Then
fTwo = fTwo + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 3 Then
fThree = fThree + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 4 Then
fFour = fFour + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 5 Then
fFive = fFive + 1
End If
rows1 = rows1 + 1
Loop
End If
Next rows1
ThisWorkbook.Sheets(1).Range("H2") = sOne
ThisWorkbook.Sheets(1).Range("H3") = sTwo
ThisWorkbook.Sheets(1).Range("H4") = sThree
ThisWorkbook.Sheets(1).Range("H5") = sFour
ThisWorkbook.Sheets(1).Range("H6") = sFive
ThisWorkbook.Sheets(1).Range("J2") = fOne
ThisWorkbook.Sheets(1).Range("J3") = fTwo
ThisWorkbook.Sheets(1).Range("J4") = fThree
ThisWorkbook.Sheets(1).Range("J5") = fFour
ThisWorkbook.Sheets(1).Range("J6") = fFive
End Sub
You don't need VBA code to do this. If your values in column A only consist of the values 1,2,3,4,5,s and f then you can use a helper column as shown in the picture, below.
The formula in cell B2 is
=IF(ISNUMBER(A2),B1,A2)
and this is copied down the remaining cells of column B. After the first s or f is encountered in A, B contains either s or f dependent on which occurred in 'most recently'.
The formula for cell E4 can be seen from the picture and copying this to range E4:I5 provides your results table.
Here's a fairly flexible approach:
Sub Tester()
Dim d As Object, x As Long, k
Dim arrL, arr, L As String, c As Range, tmp
arrL = Array("s", "f")
Set d = CreateObject("scripting.dictionary")
For x = LBound(arrL) To UBound(arrL)
d.Add arrL(x), Array(0, 0, 0, 0, 0)
Next x
Set c = ActiveSheet.Range("A1")
L = ""
Do While Len(c.Value) > 0
tmp = c.Value
If d.exists(tmp) Then
L = tmp 'save the "current" letter
Else
If IsNumeric(tmp) Then
'assuming whole numbers...
If tmp >= 1 And tmp <= 5 Then
If d.exists(L) Then
'can't modify an array stored in a dictionary: copy out
arr = d(L)
arr(tmp - 1) = arr(tmp - 1) + 1
d(L) = arr 'store back in dict
End If
End If
End If
End If
Set c = c.Offset(1, 0)
Loop
'output the letters and counts
For Each k In d.keys
Debug.Print k, Join(d(k), ", ")
Next k
End Sub