I need these values to be in this format:
Try:
Option Explicit
Sub test()
Dim LastRowA As Long, i As Long, StartPoint As Long, EndPoint As Long, y As Long, LastRowD As Long
Dim arr As Variant
Dim Char1 As String, Char2 As String
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of Column A
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set the range with data
arr = .Range("A1:A" & LastRowA)
StartPoint = 1
'Loop the range with data
For i = LBound(arr) To UBound(arr)
If StartPoint <= i Then
Char1 = Mid(arr(i, 1), 3, 1)
'Loop to find match
For y = i + 1 To UBound(arr)
Char2 = Mid(arr(y, 1), 3, 1)
If Char1 <> Char2 Then
EndPoint = y - 1
Exit For
End If
Next y
LastRowD = .Cells(.Rows.Count, "D").End(xlUp).Row
.Range("D" & LastRowD + 1).Value = Right(.Range("A" & StartPoint).Value, (Len(.Range("A" & StartPoint).Value) - 1)) & " - " & Right(.Range("A" & EndPoint).Value, (Len(.Range("A" & EndPoint).Value) - 1))
StartPoint = y
End If
Next i
End With
End Sub
Results:
Related
I am stuck in my vba code and seems I setup a loop wrong. Really appreciate for some advices! Thank you very much!!
Sub code()
Dim lastRow As Long
Dim k As Integer
Dim rowPtr As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For rowPtr = 2 To lastRow
If Range("A" & rowPtr + 1) <> Range("A" & rowPtr) Then
k = 1
Range("B" & rowPtr) = k
Else
If Range("A" & rowPtr + 1) = Range("A" & rowPtr) Then
Range("B" & rowPtr) = k
End If
k = k + 1
End If
Next
End Sub
Above is my code and now my VBA result is like this:
screenshot
Column C is my ideal result of the code
Rank Reps (Repeating Values)
Adjust the values in the constants section.
Note that Range("A" & rowPtr) is the same as Cells(rowPtr, "A") or Cells(rowPtr, 1), and Range("A" & Rows.Count) is the same as Cells(Rows.Count, "A") or Cells(Rows.Count, 1).
Option Explicit
Sub rankReps()
Const FirstRow As Long = 2
Const sCol As String = "A"
Const dCol As String = "B"
Dim cOffset As Long: cOffset = Columns(dCol).Column - Columns(sCol).Column
Dim LastRow As Long: LastRow = Range(sCol & Rows.Count).End(xlUp).Row
If LastRow < FirstRow Then
MsgBox "No data", vbCritical, "No Data"
Exit Sub
End If
' Write first.
Range(sCol & FirstRow).Offset(, cOffset).Value = 1
' Write remainder.
If LastRow > FirstRow Then
Dim cCell As Range ' Current Cell
Dim r As Long ' Row Counter
Dim rk As Long: rk = 1 ' Rank Counter
For r = FirstRow + 1 To LastRow ' +1: the first is already written
Set cCell = Range(sCol & r)
If cCell.Value = cCell.Offset(-1).Value Then
rk = rk + 1
Else
rk = 1
End If
cCell.Offset(, cOffset).Value = rk
Next r
End If
End Sub
Public Sub UpdateRankings(ByVal ws As Worksheet)
' Adjust as necessary.
Const firstRow As Long = 3
Const colGroupId As Long = 1
Const colRanking As Long = 6
Dim row As Long
With ws
' First value defaults to 1.
row = firstRow
.Cells(row, colRanking).Value = 1
' Remaining rows.
row = row + 1
Do While .Cells(row, colGroupId).Value <> ""
' If group id is the same as the previous row, increment rank.
If .Cells(row, colGroupId).Value = .Cells(row - 1, colGroupId).Value Then
.Cells(row, colRanking).Value = .Cells(row - 1, colRanking).Value + 1
' If group id has changed, reset rank to 1.
Else
.Cells(row, colRanking).Value = 1
End If
' Next row.
row = row + 1
Loop
End With
End Sub
Please, try the next way:
Sub Countcode()
Dim lastRow As Long, k As Long, rowPtr As Long
lastRow = cells(rows.count, 1).End(xlUp).row
k = 1
For rowPtr = 2 To lastRow
If Range("A" & rowPtr) = Range("A" & rowPtr + 1) Then
Range("B" & rowPtr) = k: k = k + 1
Else
If Range("A" & rowPtr) = Range("A" & rowPtr - 1) Then
Range("B" & rowPtr) = k: k=1
Else
k = 1
Range("B" & rowPtr) = k
End If
End If
Next
End Sub
One approach is:
Sub numberIt2()
Dim cl As Range, equal As Integer ' equal initial value is 0
Set cl = Range("A1")
Do While cl <> ""
cl.Offset(0, 1) = equal + 1
Set cl = cl.Offset(1)
equal = IIf(cl = cl.Offset(-1), equal + 1, 0)
Loop
End Sub
I want to check if the text value in a cell is the same as in the cell below with a for loop.
If the value in Cell(1) and Cell(2) does not match I want the value from Cell(3) written in Cell(4).
I get an error
"Overflow (Error 6)"
Dim i As Integer
For i = 1 To Rows.Count
If Cells(2 + i,21) = Cells(3 + i,21) Then
i = i + 1
Else
a = Cells(3 + i, 1)
j = j + 1
Cells(228 + j, 3) = a
End If
Next i
End Sub
I have a production output and a timeline from 6 am to 12 am and I want to create a timetable as seen below.
Screenshot:
You could use
Option Explicit
Sub test()
Dim LastRowA As Long, i As Long, j As Long, LastRowW As Long
Dim StartTime As Date, EndTime As Date, strOutPut
j = 0
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRowA
If i > j - 1 Then
StartTime = .Range("A" & i).Value
strOutPut = .Range("U" & i).Value
For j = i + 1 To LastRowA + 1
If strOutPut <> .Range("U" & j).Value Then
EndTime = .Range("A" & j - 1).Value
LastRow = .Cells(.Rows.Count, "W").End(xlUp).Row
.Range("W" & LastRow + 1).Value = StartTime
.Range("X" & LastRow + 1).Value = EndTime
.Range("Y" & LastRow + 1).Value = strOutPut
Exit For
End If
Next j
End If
Next i
End With
End Sub
Result
Here I'm using a dictionary which will store every time for every product comma separated, so later will split that and take the first and last occurrence:
Sub TimeTable()
'Declare an array variable to store the data
'change MySheet for your sheet name
arr = ThisWorkbook.Sheets("MySheet").UsedRange.Value 'this will store the whole worksheet, the used area.
'Declare a dictionary object
Dim Products As Object: Set Products = CreateObject("Scripting.Dictionary")
'Loop through the array
Dim i As Long
For i = 3 To UBound(arr) 'start from row 3 because of your screenshoot
If arr(i, 21) = vbNullString Then GoTo NextRow 'if column U is empty won't add anything
If Not Products.Exists(arr(i, 21)) Then '21 is the column index for column U
Products.Add arr(i, 21), arr(i, 1)
Else
Products(arr(i, 21)) = arr(i, 21) & "," & arr(i, 1)
End If
NextRow:
Next i
Erase arr
'Redim the array to fit your final data, 4 columns and as many rows as products
ReDim arr(1 To Products.Count + 1, 1 To 4)
'Insert the headers
arr(1, 1) = "Time"
arr(1, 4) = "Product / Error"
'Now loop through the dictionary
Dim Key As Variant, MySplit As Variant
i = 2
For Each Key In Products.Keys
MySplit = Split(Products(Key), ",")
arr(i, 1) = MySplit(LBound(MySplit))
arr(i, 2) = "-"
arr(i, 3) = MySplit(UBound(MySplit))
arr(i, 4) = Key
i = i + 1
Next Key
'I don't know where are you going to paste your data, so I'm making a new worksheet at the end of your workbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
With ws
.Range("A1").Resize(UBound(arr), UBound(arr, 2)).Value = arr
.Range("A1:C1").Merge
End With
End Sub
I want to cut the cells present from the cells in E1:G1 and add it to D2 and copy the cells in range present in A1:C1 to the next row,
and do that to next rows and so on in which they have content from the columns E to G.
I've already tried to use the "Data - Text to Columns" in Excel but I can't use that in order to copy to rows...
What I'm trying to obtain is in this format, but I'm having a hard time finding VBA code in order to do this.
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, LastColumn As Long, i As Long, y As Long
Dim Avalue As String, BValue As String, Cvalue As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 1 Step -1
Avalue = .Range("A" & i).Value
BValue = .Range("B" & i).Value
Cvalue = .Range("C" & i).Value
LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
If LastColumn > 4 Then
For y = LastColumn To 5 Step -1
.Rows(i + 1).EntireRow.Insert
.Cells(i + 1, 1).Value = Avalue
.Cells(i + 1, 2).Value = BValue
.Cells(i + 1, 3).Value = Cvalue
.Cells(i, y).Cut .Cells(i + 1, 4)
Next y
End If
Next i
End With
End Sub
Array Version
Option Explicit
Sub test()
Dim LastRow As Long, LastColumn As Long, i As Long, y As Long
Dim Avalue As String, BValue As String, Cvalue As String
Dim ABCvalues As Variant
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 1 Step -1
ABCvalues = .Range("A" & i & ":C" & i).Value
LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
If LastColumn > 4 Then
For y = LastColumn To 5 Step -1
.Rows(i + 1).EntireRow.Insert
.Range("A" & i + 1 & ":C" & i + 1).Value = ABCvalues
.Cells(i, y).Cut .Cells(i + 1, 4)
Next y
End If
Next i
End With
End Sub
I'm trying to concatenate two ranges in excel using VBA so each cell in range1 concatenates all cells in range2 until cell A is null. Please see below:
Range1(column A): Range2(column B):
50703, 50702 52797, 52848
Concatenate(column C):
50703-52797, 50703-52848, 50702-52797, 50702-52848
This will insert all the combinations of values in column A and B into column C and concatenate them with a hyphen:
Sub combinations()
Dim i As Long, j As Long, n As Long
Dim valsColA As Variant, valsColB As Variant
With ThisWorkbook.Sheets("Combinations") ' change sheet name, if necessary
valsColA = .Range(.Cells(1, 1), .Range("A1").End(xlDown)).Value
valsColB = .Range(.Cells(1, 2), .Range("B1").End(xlDown)).Value
For i = LBound(valsColA) To UBound(valsColA)
For j = LBound(valsColB) To UBound(valsColB)
n = n + 1
.Cells(n, 3).Value = valsColA(i, 1) & "-" & valsColB(j, 1)
Next j
Next i
End With
End Sub
Here is what I came up with, although #Miqi180 got there first:
Sub ABPerm()
Dim Acol As Integer
Dim Bcol As Integer
Dim RowNumA As Integer
Dim RowNumB As Integer
Dim RowNumC As Integer
Acol = Range("A" & Rows.Count).End(xlUp).Row
Bcol = Range("B" & Rows.Count).End(xlUp).Row
RowNumA = 1
RowNumB = 1
RowNumC = 1
For a = 1 To Acol
For b = 1 To Bcol
Range("C" & RowNumC).Value = Range("A" & RowNumA).Value & "-" & Range("B" & RowNumB).Value
RowNumB = RowNumB + 1
RowNumC = RowNumC + 1
Next b
RowNumB = 1
RowNumA = RowNumA + 1
Next a
End Sub
Try this code
Sub Test()
Dim rng As Range
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
rng.Offset(, 2).Value = Evaluate("If(Row(1:" & rng.Rows.Count & ")," & rng.Address(, , , True) & " & " & "-" & rng.Offset(, 1).Address(, , , True) & ")")
End Sub
Using Excel VBA, I'm trying to capture the first value in a column "Start" and the last value in a column "End", per group.
Data is already sorted.
Example:
I want to capture the first value for Start_open and the last value for Start_end per company.
So for Company A code should put B2 in Start_Open and put C5 in Start_end.
Capturing the last value works fine using this code:
Sub First_last()
Dim i, j As Integer
Dim LastRow, LastCol As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow
If Cells(i + 1, "A").Value <> Cells(i, "A").Value Then
MsgBox i
Cells(j + 2, "E").Value = Cells(i, "C").Value
j = j + 1
End If
Next
End Sub
What I'm struggling with is capturing Start_open per group.
I think I need to use above condition and use a counter to capture Start_open per group but I can't find the right code.
Please advise, thanks!
You can use variables a and b to find the start and end of each section:
Dim a as Long, b as Long, i as Long, lr as Long
lr = cells(rows.count,1).end(xlup).row
For i = 2 to lr
If cells(i,1).value = cells(i+1,1).value then
If a = 0 then
a = i + 1
End If
Else
If a > 0 AND b = 0 then
b = i + 1
End If
End If
If b > 0 AND a > 0 Then
'perform max(range(cells(a,2),cells(b,2))), etc.
a = 0 'resets for next grouping
b = 0 'resets for next grouping
End If
Next i
a = 0
b = 0
To add another method into the mix.
Sub x()
Dim r As Range, oDic As Object, r1 As Range, r2 As Range, r3 As Range, v(), i As Long
Set oDic = CreateObject("Scripting.Dictionary")
Set r = Range("A2", Range("A" & Rows.Count).End(xlUp))
ReDim v(1 To r.Count, 1 To 3)
For Each r3 In r
If Not oDic.Exists(r3.Text) Then
Set r1 = r.Find(What:=r3, After:=r(r.Count), LookAt:=xlWhole, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Set r2 = r.Find(r3, r(1), , , , xlPrevious)
i = i + 1
v(i, 1) = r3
v(i, 2) = r1.Offset(, 1).Value
v(i, 3) = r2.Offset(, 2).Value
oDic.Add r3.Text, Nothing
End If
Next r3
Range("D2").Resize(oDic.Count, 3) = v
End Sub
This will do what you want:
Sub First_Last()
With ActiveSheet
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim numUnique
numUnique = .Evaluate("SUM(1/COUNTIF(A:A,A2:A" & LastRow & "))")
Dim outarr As Variant
ReDim outarr(1 To numUnique, 1 To 2)
Dim clmc As Variant
clmc = .Range(.Cells(1, 3), .Cells(LastRow, 3)).Value
Dim clmb As Variant
clmb = .Range(.Cells(1, 2), .Cells(LastRow, 2)).Value
Dim j As Long
j = 1
Dim i As Long
For i = 2 To LastRow
outarr(j, 1) = clmb(i, 1)
Dim k As Long
k = .Evaluate("AGGREGATE(14,6,ROW(A2:A" & LastRow & ")/(A2:A" & LastRow & " = " & .Cells(i, 1).Address & "),1)")
outarr(j, 2) = clmc(k, 1)
j = j + 1
i = k
Next i
.Range("D2").Resize(UBound(outarr, 1), UBound(outarr, 2)).Value = outarr
End With
End Sub