please assist my thought below, I would like to get the value place in different rows according to the value. I believe my code is with looping issues but I can't figure out why.
The action is very simple, row A is a set of value, if range("A2").value + 50 <= 100 then place the answer on B2.value, else place value on C2.value and etc.
Sub ttest()
Dim item, lastR, itemplus As Integer
Dim i, j As Integer
i = 2
j = 2
item = Cells(i, 1).value
lastR = Cells(Rows.Count, 1).End(xlUp).row
itemplus = item + 50
For i = 2 To lastR
If itemplus <= 100 Then
Cells(i, j).value = itemplus
Else
Cells(i, j + 1).value = itemplus
End If
item = Cells(i, 1).value
Next i
End Sub
As #SJR says, you partly work outside your loop and partly inside your loop, constantly comparing to the exact same variable.
May I suggest an alternative to work through memory instead (and avoid slower calls to your worksheet too often):
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lr As Long, x As Long
Dim arr As Variant
With ws
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A2:C" & lr).Value
For x = LBound(arr) To UBound(arr)
If arr(x, 1) < 50 Then
arr(x, 2) = arr(x, 1)
Else
arr(x, 3) = arr(x, 1)
End If
Next
.Range("A2:C" & lr).Value = arr
End With
End Sub
As you may notice, we don't have to add 50 to each value to compare if its <= to a 100. That would imply that the initial value must simply be below 50.
That being said, the same is achieved swiftly through native Excel functions if you would want to avoid VBA.
Just change the order of assignment:
Sub ttest()
Dim item, lastR, itemplus As Integer
Dim i, j As Integer
i = 2
j = 2
item = Cells(i, 1).Value
lastR = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastR
item = Cells(i, 1).Value
itemplus = item + 50
If itemplus <= 100 Then
Cells(i, j).Value = itemplus
Else
Cells(i, j + 1).Value = itemplus
End If
Next i
End Sub
Sub test()
Set Rng = Range("A2", Range("A2").End(xlDown))
For Each cell In Rng
Sum = cell.Value + 50
If Sum <= 100 Then cell.Offset(0, 1).Value = Sum
If Sum > 100 Then cell.Offset(0, 2).Value = Sum
Next
End Sub
Related
I am working on a problem to find combinations equal to 100 with different vector length as input. The code is working fine for the small sequence but code takes a lot of time when the sequence of numbers increases. I need to reduce the time as much as I can because sometimes it takes an hour. The maximum value of vector length can be 6 & minimum increment can be 5 so the maximum we can get is 36 numbers and output of their combinations in a set of 6. Any help in the optimization of code to a minimum possible time would be great.
Here is the snap of sheet:
Here is the code:
Sub Combinations()
Dim rRng As Range, p As Integer
Dim vElements, lrow As Long, vresult As Variant
Range("A2:A100").Clear
Call Sequence
lrow = 25
Set rRng = Range("A2", Range("A2").End(xlDown)) ' The set of numbers
p = Range("C2").Value ' How many are picked
vElements = Application.Index(Application.Transpose(rRng), 1, 0)
ReDim vresult(1 To p)
Columns("E").Resize(, p + 5).Clear
Call CombinationsNP(vElements, p, vresult, lrow, 1, 1)
Call Delrow
Call formu
Range("C27:D15000").Clear
End Sub
Sub CombinationsNP(vElements As Variant, p As Integer, vresult As Variant, lrow As Long, iElement As Integer, iIndex As Integer)
Dim i As Integer
For i = iElement To UBound(vElements)
vresult(iIndex) = vElements(i)
If iIndex = p Then
lrow = lrow + 1
Range("E" & lrow + 1).Resize(, p) = vresult
Else
Call CombinationsNP(vElements, p, vresult, lrow, i + 1, iIndex + 1)
End If
Next i
End Sub
Sub Delrow()
Dim lrow As Long
Dim i As Long
Dim x As Integer
lrow = Cells(Rows.Count, 5).End(xlUp).Row
For i = 27 To lrow + 1
x = Cells(i, 5).Value + Cells(i, 6).Value + Cells(i, 7).Value + Cells(i, 8).Value + Cells(i, 9).Value + Cells(i, 10).Value
If x <> 100 And Cells(i, 5).Value <> "" Then
Cells(i, 5).EntireRow.Delete
i = i - 1
End If
Next i
End Sub
Sub Sequence()
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim a As Integer
Dim b As Integer
b = Cells(2, 3).Value
For i = 2 To Cells(2, 3).Value - 1
Cells(i, 1).Value = 0
Next i
For y = 0 To 100 Step Cells(8, 3).Value
a = 1
If y <> 0 Then
a = Int(100 / y)
If a > b Then
a = b
End If
End If
For x = 1 To a
Cells(i, 1).Value = y
i = i + 1
Next x
Next y
End Sub
Sub formu()
Dim lastrow As Long
lastrow = Cells(Rows.Count, 5).End(xlUp).Row
Range("D27:D" & lastrow).formula = "=E27&F27&G27&H27&I27&J27"
Range("C27:C" & lastrow).formula = "=IF(COUNTIF($D$27:$D$150000,D27)=1,FALSE,NOT(COUNTIF($D$2:D27,D27)=1))"
Range("$C$26:$C$150000").AutoFilter Field:=1, Criteria1:="TRUE"
Range("C27:C150000").EntireRow.Delete
Sheet5.ShowAllData
End Sub
I think this code is slow because of how often it touches the worksheet. There are both read and writes to worksheets in loops. There is also a recursive function that writes to the worksheet in a loop. I can't tell if you are doing this for ease of use or because you need to display the output. Avoid writing to the worksheet until output is required. Output all the data at once, instead of one cell at a time. See the example I give in the Sequence procedure.
I made the code have fully defined references so the system has to do less guessing and lookups. I doubt the performance change will be drastic.
Option Explicit
Public Sub Combinations()
Dim rRng As Range
Dim p As Long
Dim vElements As Variant
Dim lrow As Long
ActiveSheet.Range("A2:A100").Clear
Sequence
lrow = 25
Set rRng = ActiveSheet.Range("A2", ActiveSheet.Range("A2").End(xlDown)) ' The set of numbers
p = ActiveSheet.Range("C2").Value ' How many are picked
vElements = Application.WorksheetFunction.Index(Application.WorksheetFunction.Transpose(rRng), 1, 0)
ReDim vresult(1 To p)
ActiveSheet.Columns("E").Resize(, p + 5).Clear
CombinationsNP vElements, p, vresult, lrow, 1, 1
Delrow
formu
ActiveSheet.Range("C27:D15000").Clear
End Sub
Public Sub CombinationsNP(vElements As Variant, p As Long, vresult As Variant, lrow As Long, ByVal iElement As Long, iIndex As Long)
Dim i As Long
For i = iElement To UBound(vElements)
vresult(iIndex) = vElements(i)
If iIndex = p Then
lrow = lrow + 1
ActiveSheet.Range("E" & lrow + 1).Resize(, p) = vresult
Else
CombinationsNP vElements, p, vresult, lrow, i + 1, iIndex + 1
End If
Next i
End Sub
Public Sub Delrow()
Dim lrow As Long
Dim i As Long
Dim x As Long
With ActiveSheet
lrow = .Cells(.Rows.Count, 5).End(xlUp).Row
For i = 27 To lrow + 1
x = .Cells(i, 5).Value + .Cells(i, 6).Value + .Cells(i, 7).Value + .Cells(i, 8).Value + .Cells(i, 9).Value + .Cells(i, 10).Value
If x <> 100 And .Cells(i, 5).Value <> vbNullString Then
.Cells(i, 5).EntireRow.Delete
i = i - 1
End If
Next i
End With
End Sub
Public Sub Sequence()
Dim i As Long
Dim x As Long
Dim y As Long
Dim a As Long
Dim b As Long
' Example of setting all the cells at once
With ActiveSheet
b = .Cells(2, 3).Value
.Range(.Cells(2, 1), .Cells(b - 1, 1)).Value = 0
End With
For y = 0 To 100 Step ActiveSheet.Cells(8, 3).Value
a = 1
If y <> 0 Then
a = Int(100 / y)
If a > b Then
a = b
End If
End If
For x = 1 To a
ActiveSheet.Cells(i, 1).Value = y
i = i + 1
Next x
Next y
End Sub
Public Sub formu()
Dim lastrow As Long
With ActiveSheet
lastrow = .Cells(.Rows.Count, 5).End(xlUp).Row
.Range("D27:D" & lastrow).Formula = "=E27&F27&G27&H27&I27&J27"
.Range("C27:C" & lastrow).Formula = "=IF(COUNTIF($D$27:$D$150000,D27)=1,FALSE,NOT(COUNTIF($D$2:D27,D27)=1))"
.Range("$C$26:$C$150000").AutoFilter Field:=1, Criteria1:="TRUE"
.Range("C27:C150000").EntireRow.Delete
End With
Sheet5.ShowAllData
End Sub
How do i put multiple values from different cells (eg: values that lies below header x rel and y rel previously obtained by my program) and put them in the same cell which lies the same row as device d?(not manually select in excel or selectively using coding). What my current code does is to locate the x and y values of reliability fails then stored them in array(not sure is it correct or not) but after that how to concatenate them in the same cell shown in "After"?
Public Sub FindAndConvertforreliabilityfails()
Dim i As Integer
Dim j As Integer
Dim lastRow As Long
Dim myRng As Range
Dim mycell As Range
Dim MyColl As Collection
Dim myIterator As Variant
Set MyColl = New Collection
Dim xpos As integr, ypos As Integer
MyColl.Add "x rel"
MyColl.Add "y rel"
Dim LastCol As Integer
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To LastCol
For j = 1 To lastRow
For Each myIterator In MyColl
Do While Sheets(1).Cells(1, j).Value <> ""
If Sheets(1).Cells(1, i).Value = myIterator Then
xpos(j) = Sheets(1).Cells(Rows.Count, 6).End(xlUp).Offset(1, 0)
Else
ypos(j) = Sheets(1).Cells(Rows.Count, 7).End(xlUp).Offset(1, 0)
End If
Loop
Next
Next
' how to continue from here for the concatenate portion?
End Sub
Before
After
Currently
Try this. This will give you the expected output.
Private Sub Test()
Dim output As Variant
Dim outputrow As Integer
output = ""
outputrow = 0
For i = 2 To 5 'change 5 to lastrow of F&G Column.
If Cells(i, "B").Value = 0 Then
output = output & "(" & Cells(i, "F").Value & "," & Cells(i, "G").Value & "),"
Else
Cells(i, "E") = Left(output, Len(output) - 1)
output = "(" & Cells(i, "F").Value & "," & Cells(i, "G").Value & "),"
End If
Next i
Cells(i, "E") = Left(output, Len(output) - 1)
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
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
Example of my dataset:
blank
1
2
blank
3
4
5
blank
6
I want to merge all cells below a blank cell into the blank cell, but stop counting when it reaches the next blank cell.
End result should look like this, with the strings concatenated
12
345
6
I'm currently trying to create an array with 1s and 2s with 2 meaning its a blank cell, then counting the 1s and merging them. I don't know if this will work or if there is an easier way to do this.
This requires you to select the area you want to merge, starting with the first blank cell and ending with the last cell with a value. It will delete entire rows; not sure if that's what you wanted:
Sub MergeConstantsIntoEmpties()
Dim BlankCells As Excel.Range
Dim ConstantCells As Excel.Range
Dim i As Long
Dim MungedContents As String
With Selection
Set BlankCells = .SpecialCells(xlCellTypeBlanks)
Set ConstantCells = .SpecialCells(xlCellTypeConstants)
End With
For i = 1 To BlankCells.Areas.Count
If ConstantCells.Areas(i).Count = 1 Then
MungedContents = ConstantCells.Areas(i).Value
Else
MungedContents = Join(Application.WorksheetFunction.Transpose(ConstantCells.Areas(i).Value))
End If
BlankCells.Areas(i).Value = MungedContents
Next i
ConstantCells.EntireRow.Delete
End Sub
If we start with:
and run this macro:
Sub PileOn()
Dim N As Long, st As String
Dim i As Long, v As Variant
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
v = Cells(i, 1).Value
If v <> "" Then
st = st & v
Cells(i, 1).Delete shift:=xlUp
Else
Cells(i, 1).Value = st
st = ""
End If
Next i
End Sub
We end up with:
EDIT#1:
To fix the order of the concatenated cells use this instead:
Sub PileOn()
Dim N As Long, st As String
Dim i As Long, v As Variant
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
v = Cells(i, 1).Value
If v <> "" Then
st = v & st
Cells(i, 1).Delete shift:=xlUp
Else
Cells(i, 1).Value = st
st = ""
End If
Next i
End Sub
Here is my take on it.
Sub JoinBetweenTheLines()
Dim X As Long
X = 1
Do Until X >= Range("A" & Rows.Count).End(xlUp).Row
If Range("A" & X).text = "" Then
Range("A" & X).Delete xlUp
ElseIf Range("A" & X).Offset(1, 0).text = "" Then
X = X + 1
Else
Range("A" & X).Formula = Join(Application.Transpose(Range("A" & X & ":A" & X + 1)), "")
Range("A" & X + 1).Delete xlUp
End If
Loop
End Sub
I normally work backwards also but for this one went forwards.
I had memory processing in mind.
Sub merg()
Dim v As Long, w As Long, vVALs As Variant
With ActiveSheet 'reference the worksheet properly!
With .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
vVALs = .Cells.Value2
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
If vVALs(v, 1) = vbNullString Then
For w = v + 1 To UBound(vVALs, 1)
If vVALs(w, 1) = vbNullString Then Exit For
vVALs(v, 1) = vVALs(v, 1) & vVALs(w, 1)
vVALs(w, 1) = vbNullString
Next w
End If
Next v
.Cells = vVALs
With .SpecialCells(xlCellTypeBlanks)
.Delete Shift:=xlUp
End With
End With
End With
End Sub