I want to have 2 formulas with continuous looping as long as there is value in the cell next to the targeted cell, thus i need to have ifelse function but with continuous looping aswell. for now i don't know how to insert the second formula.
Range("D9").Select
Set ws = Sheets("LAP KEL BIAYA")
lastRow = ws.Range("C" & Rows.Count).End(xlUp).Row
With ws
For i = 9 To lastRow
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
Function Total(Text, Number)
.Range("D" & i).Formula = "=IF(RC[-3]=""B"",IF(AND(R4C3>0,R5C3>0),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C[47],RC[-1]),IF(AND(R4C3>0,R5C3=""""),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[16],R7C4,FBL3N!C[47],'LAP KEL BIAYA'!RC[-1]),IF(AND(R4C3=0,R5C3>0),SUMIFS(FBL3N!C[11],FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C[47],RC[-1]),IF(AND(R4C3=0,R5C3=0),SUMIFS(F" & _
"BL3N!C[11],FBL3N!C[16],R7C4,FBL3N!C[47],RC[-1]),"""")))))" & _
""
ElseIf Total = "False" Then
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
.Range("D" & i).Formula = "=IF(AND(R4C3>0,R5C3>0,OR(R[-1]C1=""7"",R[-1]C1=""5"",R[-1]C1=""4"")),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C,R[-1]C[-1]),IF(AND(R4C3>0,R5C3=0),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[16],R7C4,FBL3N!C,'LAP KEL BIAYA'!R[-1]C[-1]),IF(AND(R4C3=0,R5C3>0),SUMIFS(FBL3N!C[11],FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C,R[-1]C[-1]),IF(" & _
"AND(R4C3=0,R5C3=0),SUMIFS(FBL3N!C[11],FBL3N!C[16],R7C4,FBL3N!C,R[-1]C[-1])))))" & _
""
.Range("D" & i).Font.Color = vbRed
End If
Next i
End Function
End With
I'm writing a code that calculate number automatically every time you edit a sheet. But somehow the code I wrote is not functioning properly that it gives a run-time error. I checked the cells and range but they are all valid and correct. All of the inputs and variables involved are simple integers (no more than 3 digits).
I just got a work assignment to automate some excel sheets at work and I just learned vba from ground up recently.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Integer
Dim i As Byte
i = 5
For i = 5 To 12
If Worksheets("Sheet1").Range("D" & i).Value = "" Or Worksheets("Sheet1").Range("D" & i).Value = 0 Then
A = Worksheets("Sheet1").Range("E" & i).Value - Worksheets("Sheet1").Range("C" & i).Value
Worksheets("Sheet1").Range("F" & i).Value = A
Else
Worksheets("Sheet1").Range("F" & i).Value = Worksheets("Sheet1").Range("D" & i).Value * Worksheets("Sheet1").Range("B" & i).Value _
+ Worksheets("Sheet1").Range("E" & i).Value - Worksheets("Sheet1").Range("C" & i).Value
End If
Next i
End Sub
It gives a run-time error
Give this a shot and let me know what error you get:
Private Sub Worksheet_Change(ByVal Target As Range)
'Only run if something changes in column D or E
If Target.Column = 4 Or Target.Column = 5 Then
'Turn off any events so that we don't encounter recursion
Application.EnableEvents = False
'This will help readability a bit
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("Sheet1")
Dim A As Integer
Dim i As Long
'This needs to be removed - it's irrelevant as i is used as an iterable on the next line
'i = 5
For i = 5 To 12
If sht.Range("D" & i).Value = "" Or sht.Range("D" & i).Value = 0 Then
'What's the point of using a variable here?
A = sht.Range("E" & i).Value - sht.Range("C" & i).Value
sht.Range("F" & i).Value = A
Else
'Order of operations - is that important here?
'Are we certain these fields are numeric?
sht.Range("F" & i).Value = sht.Range("D" & i).Value * sht.Range("B" & i).Value _
+ sht.Range("E" & i).Value - sht.Range("C" & i).Value
End If
Next i
'Turn it back on once we're done
Application.EnableEvents = True
End If
End Sub
I automating a spreadsheet cleaning tools that removes data from the spreadsheet if certain values are in a particular column. Originally, it deleted entire rows of data if the specific value is found. However, this is causing numerous reference errors by deleting the rows. Sample of the original code below.
Set rData = .Range("L5:L" & last & ",AX5:AX" & last)
For i = rData.Row To rData.Row + rData.Rows.Count - 1
If .Range("AX" & i) = "DONE" Or .Range("AX" & i) = "CANCEL" Then
.Range("A" & i, "AX" & i).Copy
bottom = activewkb.Worksheets("OrderStatus").Range("I" & Rows.Count).End(xlUp).Row + 1
activewkb.Worksheets("OrderStatus").Range("A" & bottom).PasteSpecial Paste:=xlPasteValues
If i > 0 Then
.Range("D" & i & ":CA" & i).ClearContents
End If
End If
Next i
The easiest way to get rid of the reference errors is to clear the contents from column D through DD if the requirements are satisfied then shift all of the data below it up for column D to DD up one row. The new code is below. I am getting an error on the .Range("D" & i).Offset(1,0).Value line.
Set rData = .Range("L5:L" & last & ",AX5:AX" & last)
For i = rData.Row To rData.Row + rData.Rows.Count - 1
If .Range("AX" & i) = "DONE" Or .Range("AX" & i) = "CANCEL" Then
.Range("A" & i, "AX" & i).Copy
bottom = activewkb.Worksheets("OrderStatus").Range("I" & Rows.Count).End(xlUp).Row + 1
activewkb.Worksheets("OrderStatus").Range("A" & bottom).PasteSpecial Paste:=xlPasteValues
If i > 0 Then
.Range("D" & i & ":CA" & i).ClearContents
.Range("D" & i).Offset(1, 0).Value
.Offset(1, 0).Select
End If
End If
Next i
Any suggestions are appreciated! Thanks in advance.
Final One:enter image description hereI want to insert blank row with a specific column range above a particular row.
For example:
There were 2 sets of data in a single sheet ,ie, 1st set col A to Col E and 2nd set Col F to Col J. I need to compare Column Ai with Column Fi (where i indicates the position of row) and if both values are same then the comparison can be proceeded like Bi with Gi, Ci with Hi and so and so and if not, I need to shift that set of 2nd data Fi to Ji to next row..ie. if the whole set is in 6th position I need to shift them down to 7th position and make the 6th position of Fi to Ji blank....
Sub Dcompare()
Dim endRow As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
endRow = Sheet1.Range("A999999").End(xlUp).Row
For i = 2 To endRow
If Sheet1.Range("A" & i).Value = Sheet1.Range("F" & i).Value Then
Sheet1.Range("K" & i).Value = "Yes"
Else
ws.Range("F" & i & ":J" & i).Offset(1, 0).Value = ws.Range("F" & i & ":J" & i).Value
ws.Range("F" & i & ":J" & i).Value = ""
End If
Next i
For j = 2 To endRow
If Sheet1.Range("K" & j).Value = "Yes" Then
If Sheet1.Range("B" & j).Value = Sheet1.Range("G" & j).Value Then
Sheet1.Range("L" & j).Value = "Yes"
Else
Sheet1.Range("L" & j).Value = "No"
End If
If Sheet1.Range("C" & j).Value = Sheet1.Range("H" & j).Value Then
Sheet1.Range("M" & j).Value = "Yes"
Else
Sheet1.Range("M" & j).Value = "No"
End If
If Sheet1.Range("D" & j).Value = Sheet1.Range("I" & j).Value Then
Sheet1.Range("N" & j).Value = "Yes"
Else
Sheet1.Range("N" & j).Value = "No"
End If
If Sheet1.Range("E" & j).Value = Sheet1.Range("J" & j).Value Then
Sheet1.Range("O" & j).Value = "Yes"
Else
Sheet1.Range("O" & j).Value = "No"
End If
End If
Next j
End Sub
------>Final Code Inserted---------
Sub Dcompare()
Dim endRow As Long
Dim ws As Worksheet
Dim dShift As Boolean
Set ws = ThisWorkbook.Worksheets(1)
endRow = ws.Range("A999999").End(xlUp).Row
For i = 2 To endRow + 1
If ws.Range("A" & i).Value = ws.Range("F" & i).Value Then
dShift = False
ws.Range("K" & i).Value = "Yes"
Else
If Not dShift Then
ws.Range("F" & i & ":J" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ws.Range("A" & i + 1 & ":E" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
endRow = endRow + 1
dShift = True
Else
dShift = False
End If
End If
j = i
If ws.Range("K" & j).Value = "Yes" Then
If ws.Range("B" & j).Value = ws.Range("G" & j).Value Then
ws.Range("L" & j).Value = "Yes"
Else
ws.Range("L" & j).Value = "No"
End If
If ws.Range("C" & j).Value = ws.Range("H" & j).Value Then
ws.Range("M" & j).Value = "Yes"
Else
ws.Range("M" & j).Value = "No"
End If
If ws.Range("D" & j).Value = ws.Range("I" & j).Value Then
ws.Range("N" & j).Value = "Yes"
Else
ws.Range("N" & j).Value = "No"
End If
If ws.Range("E" & j).Value = ws.Range("J" & j).Value Then
ws.Range("O" & j).Value = "Yes"
Else
ws.Range("O" & j).Value = "No"
End If
Else
End If
Next i
MsgBox "The value of endRow is : " & endRow, vbInformation
End Sub
Based on your explanations, this is what I interpret your challenge as:
Evaluate Ai with Fi --> Ei with Ji from left to right, and indicate in helper-columns whether the evaluation succeeded or not
If the first evaluation is Not Equal, offset the range Fi:Ji downwards exactly one row
If a range has been shifted down, the loop should evaluate this line but never shift it again regardless of outcome of the evaluation
This code satisfies those conditions (change i and other row variables to your needs):
Sub Dcompare()
Dim endRow As Long
Dim ws As Worksheet
Dim dShift As Boolean
Set ws = ThisWorkbook.Worksheets(1)
endRow = ws.Range("A999999").End(xlUp).Row
' Set initial value of helper columns to no - saves miniscule time and complexity in the loop
ws.Range("L" & 1 & ":O" & endRow).Value = "No"
For i = 1 To endRow
If ws.Range("A" & i).Value = ws.Range("F" & i).Value Then
dShift = False
ws.Range("L" & i).Value = "Yes"
Else
If Not dShift Then
ws.Range("F" & i & ":J" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
' Remember that we just shifted a row
dShift = True
Else
' Reset shift counter
dShift = False
End If
End If
For j = 2 To 4
If dShift Then Exit For
If ws.Cells(i, j).Value = ws.Cells(i, j + 5).Value Then ws.Cells(i, j + 11).Value = "Yes"
Next j
Next i
End Sub
However, it seems strange to me that you would want this functionality? Please confirm that it is correct. The behavior it yields in the worksheet is very strange.
Let me show with images. Orange background means the code will show the cell as a match. Green background means the code will show that the cell doesn't match.
Before the code it looks like this:
After the code it looks like this:
I have about 70,000 rows of data and two columns (Field,Data) which repeats every 50-100 rows (Record). I would like to write something that searches for the values based on "Field Text" (I'm only interested in about 5 fields) and paste the value into a new worksheet with rows as records and columns as fields. The first field I'm searching for will need to indicate new row/record.
My first attempt at this failed, and I've found little help on the forums. Although it looks like maybe a pivot table could do this?
Visual of what I'd like to do:
Example
EDIT:
I got the result I wanted but my do until "END" isnt catching. I do have "END" in the last cell of the data. Also, I'm sure there is a more efficient way to do this, any advice? Thanks!
Sub TracePull()
Dim i As Long
Dim j As Long
i = 1
j = 1
ActiveWorkbook.Sheets("Trace").Range("A1").Select
Do Until Range("A" & i) = "END"
Do Until ActiveCell = "OTDRFilename"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRFilename" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("A" & j + 1).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
j = j + 1
'Else
' i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRSpan length"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRSpan length" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("B" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRSpan loss"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRSpan loss" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("C" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRAverage loss"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRAverage loss" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("D" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRSpan ORL"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRSpan ORL" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("E" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRWavelength"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRWavelength" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("F" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
Range("A" & i).Select
Loop
End Sub
I think your main problem is incrementing i twice (which passes 'END' cell) at the bottom of your code.
One way to make it more readable is by using select case. Also, you can speed up the code by assigning the value directly (without copy paste) and by turning off screen updating since you have 70,000 rows. Those things will improve performance considerably.
Sub TracePull()
ScreenUpdating = False
Dim i As Long
Dim j As Long
i = 1
j = 1
ActiveWorkbook.Sheets("Trace").Range("A1").Select
Do Until Range("A" & i) = "END"
Select Case ActiveCell.Text
Case "OTDRFilename"
ActiveWorkbook.Sheets("Sheet1").Range("A" & j + 1).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRSpan length"
ActiveWorkbook.Sheets("Sheet1").Range("B" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRSpan loss"
ActiveWorkbook.Sheets("Sheet1").Range("C" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRAverage loss"
ActiveWorkbook.Sheets("Sheet1").Range("D" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRSpan ORL"
ActiveWorkbook.Sheets("Sheet1").Range("E" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRWavelength"
ActiveWorkbook.Sheets("Sheet1").Range("F" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
End Select
i = i + 1
j = j + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
Loop
ScreenUpdating = True
End Sub
You might also want to consider defining the workbook and worksheet rather than relying upon activesheet. In addition, the code with break if someone forget to have 'END' entered in the last cell, so maybe just get last cell used instead of looking for 'END'
Dim wb As Workbook
Dim wskA As Worksheet
Dim wskB As Worksheet
wb = ActiveWorkbook
wskA = wb.Sheets("Trace")
wskB = wb.Sheets("Sheet1")
numofrows = wskA.Offset(wskA.Rows.Count - 1, 0).End(xlUp).Row
wskA.Range("A1").Select
Do Until i > numofrows
Select Case ActiveCell.Text
Case "OTDRFilename"
wskB.Range("A" & j + 1).Value = wskA.Range("B" & i).Value