I have a simple yet infuriating question about a piece of code I am writing. For whatever reason, it insists I do no have a Do for my loop despite the do clearly being at the top. Perhaps I've done something while writing my If statements but I do not believe so. If you could look at it and help me out that would be great. Most of the code is a bunch of If, Then, GoTo statement so feel free to skim it.
Do While Cells(i, "B").Value <> ""
'X Block
If Cells(i, "B").Value = "U" Then
GoTo U1:
ElseIf Cells(i, "B").Value = "C" Then
GoTo C1:
ElseIf Cells(i, "B").Value = "A" Then
GoTo A1:
ElseIf Cells(i, "B").Value = "G" Then
GoTo G1:
End If
'UX Block
U1: If Cells(i + 1, "B").Value = "U" Then
GoTo UU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo UC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo UA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo UG2:
End If
'UUX Block
UU2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Phe"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Leu"
End If
GoTo EndOfAcids:
'UCX Block
UC2: Cells(a, "C").Value = "Ser"
GoTo EndOfAcids:
'UAX Block
UA2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Tyr"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Stop Codon"
End If
GoTo EndOfAcids:
'UGX Block
UG2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Cys"
ElseIf Cells(i + 2, "B").Value = "A" Then
Cells(a, "C").Value = "Stop Codon"
ElseIf Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Trp"
End If
GoTo EndOfAcids:
'CX Block
C1: If Cells(i + 1, "B").Value = "U" Then
GoTo CU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo CC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo CA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo CG2:
End If
'CUX Block
CU2: Cells(a, "C").Value = "Leu"
GoTo EndOfAcids:
'CCX Block
CC2: Cells(a, "C").Value = "Pro"
GoTo EndOfAcids:
'CAX Block
CA2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "His"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Gln"
End If
GoTo EndOfAcids:
'CGX Block
CG2: Cells(a, "C").Value = "Arg"
GoTo EndOfAcids:
'AX Block
A1: If Cells(i + 1, "B").Value = "U" Then
GoTo AU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo AC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo AA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo AG2:
End If
'AUX Block
AU2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Or Cells(i + 2).Value = "A" Then
Cells(a, "C").Value = "Ile"
ElseIf Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Met"
End If
GoTo EndOfAcids:
'ACX Block
AC2: Cells(a, "C").Value = "Thr"
GoTo EndOfAcids:
'AAX Block
AA2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Asn"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Lys"
End If
GoTo EndOfAcids:
'AGX Block
AG2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Ser"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Arg"
End If
GoTo EndOfAcids:
'GX Block
G1: If Cells(i + 1, "B").Value = "U" Then
GoTo GU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo GC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo GA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo GG2:
End If
'GUX Block
GU2: Cells(a, "C").Value = "Val"
GoTo EndOfAcids:
'GCX Block
GC2: Cells(a, "C").Value = "Ala"
GoTo EndOfAcids:
'GAX Block
GA2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Asp"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Glu"
GoTo EndOfAcids:
'GGX Block
GG2: Cells(a, "C").Value = "Gly"
GoTo EndOfAcids:
EndOfAcids:
i = i + 3
a = a + 1
Loop
End Sub
So the do is at the top of the code but when I run it the program says there is no do. Not sure why. Any help would be appreciated. There is slightly more code so I will post the entirety below but the problem loop is what is posted above.
Option Explicit
Sub RNATrascription()
Dim i As Long
Dim a As Long
i = 2
a = 2
Do While Cells(i, "A").Value <> ""
If Cells(i, "A").Value = "A" Or Cells(i, "A").Value = "a" Then
Cells(i, "B").Value = "U"
ElseIf Cells(i, "A").Value = "T" Or Cells(i, "A").Value = "t" Then
Cells(i, "B").Value = "A"
ElseIf Cells(i, "A") = "G" Or Cells(i, "A").Value = "g" Then
Cells(i, "B") = "C"
ElseIf Cells(i, "A") = "C" Or Cells(i, "A").Value = "c" Then
Cells(i, "B") = "G"
ElseIf Cells(i, "A") <> "A" Or Cells(i, "A") <> "a" Or Cells(i, "A") <> "T" Or Cells(i, "A") <> "t" Or Cells(i, "A") <> "G" Or Cells(i, "A") <> "g" Or Cells(i, "A") <> "C" Or Cells(i, "A") <> "c" Then
MsgBox "You have mis typed your DNA sequence"
End If
i = i + 1
Loop
Do While Cells(i, "B").Value <> ""
'X Block
If Cells(i, "B").Value = "U" Then
GoTo U1:
ElseIf Cells(i, "B").Value = "C" Then
GoTo C1:
ElseIf Cells(i, "B").Value = "A" Then
GoTo A1:
ElseIf Cells(i, "B").Value = "G" Then
GoTo G1:
End If
'UX Block
U1: If Cells(i + 1, "B").Value = "U" Then
GoTo UU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo UC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo UA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo UG2:
End If
'UUX Block
UU2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Phe"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Leu"
End If
GoTo EndOfAcids:
'UCX Block
UC2: Cells(a, "C").Value = "Ser"
GoTo EndOfAcids:
'UAX Block
UA2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Tyr"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Stop Codon"
End If
GoTo EndOfAcids:
'UGX Block
UG2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Cys"
ElseIf Cells(i + 2, "B").Value = "A" Then
Cells(a, "C").Value = "Stop Codon"
ElseIf Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Trp"
End If
GoTo EndOfAcids:
'CX Block
C1: If Cells(i + 1, "B").Value = "U" Then
GoTo CU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo CC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo CA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo CG2:
End If
'CUX Block
CU2: Cells(a, "C").Value = "Leu"
GoTo EndOfAcids:
'CCX Block
CC2: Cells(a, "C").Value = "Pro"
GoTo EndOfAcids:
'CAX Block
CA2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "His"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Gln"
End If
GoTo EndOfAcids:
'CGX Block
CG2: Cells(a, "C").Value = "Arg"
GoTo EndOfAcids:
'AX Block
A1: If Cells(i + 1, "B").Value = "U" Then
GoTo AU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo AC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo AA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo AG2:
End If
'AUX Block
AU2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Or Cells(i + 2).Value = "A" Then
Cells(a, "C").Value = "Ile"
ElseIf Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Met"
End If
GoTo EndOfAcids:
'ACX Block
AC2: Cells(a, "C").Value = "Thr"
GoTo EndOfAcids:
'AAX Block
AA2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Asn"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Lys"
End If
GoTo EndOfAcids:
'AGX Block
AG2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Ser"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Arg"
End If
GoTo EndOfAcids:
'GX Block
G1: If Cells(i + 1, "B").Value = "U" Then
GoTo GU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo GC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo GA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo GG2:
End If
'GUX Block
GU2: Cells(a, "C").Value = "Val"
GoTo EndOfAcids:
'GCX Block
GC2: Cells(a, "C").Value = "Ala"
GoTo EndOfAcids:
'GAX Block
GA2: If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Asp"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Glu"
GoTo EndOfAcids:
'GGX Block
GG2: Cells(a, "C").Value = "Gly"
GoTo EndOfAcids:
EndOfAcids:
i = i + 3
a = a + 1
Loop
End Sub
try this
Option Explicit
Sub RNATrascription()
Dim i As Long
Dim a As Long
Dim dat As String
i = 2
Do While Cells(i, "A").Value <> ""
Select Case LCase(Cells(i, "A").Value)
Case "a": dat = "U"
Case "t": dat = "A"
Case "g": dat = "C"
Case "c": dat = "G"
Case Else
MsgBox "You have mis typed your DNA sequence"
End
End Select
Cells(i, "B") = dat
i = i + 1
Loop
i = 2
a = 2
Dim cc2 As String
Dim cc3 As String
Do While Cells(i, "B").Value <> ""
cc2 = Cells(i, "B") & Cells(i + 1, "B")
cc3 = cc2 & Cells(i + 2, "B")
dat = ""
Select Case cc2
Case "uc": dat = "Ser"
Case "cu": dat = "Leu"
Case "cc": dat = "Pro"
Case "ac": dat = "Thr"
Case "gu": dat = "Val"
Case "gc": dat = "Ala"
End Select
If dat = "" Then
Select Case cc3
Case "uuu", "uuc": dat = "Phe"
Case "uua", "uug": dat = "Ley"
Case "uau", "uac": dat = "Tyr"
Case "uaa", "uag", "uga": dat = "Stop Codon"
Case "ugu", "ugc": dat = "Sys"
Case "ugg": dat = "Trp"
Case "cau": dat = "His"
Case "caa": dat = "Gln"
Case "cgc": dat = "Arg"
Case "auu", "aua": dat = "Ile"
Case "aug": dat = "Met"
Case "aau", "agu", "agc": dat = "Asn"
Case "aaa", "aga", "agg": dat = "Lys"
Case "gau", "gac": dat = "Asp"
Case "gaa", "gag": dat = "Glu"
Case Else: dat = "ERROR"
End Select
End If
Cells(a, "C").Value = dat
i = i + 3
a = a + 1
Loop
End Sub
your code should have been formatted something like this .... if you did that in the first place, you may have noticed that there is no end if in the GAX block
Option Explicit
Sub RNATrascription()
Dim i As Long
Dim a As Long
i = 2
a = 2
Do While Cells(i, "A").Value <> ""
If Cells(i, "A").Value = "A" Or Cells(i, "A").Value = "a" Then
Cells(i, "B").Value = "U"
ElseIf Cells(i, "A").Value = "T" Or Cells(i, "A").Value = "t" Then
Cells(i, "B").Value = "A"
ElseIf Cells(i, "A") = "G" Or Cells(i, "A").Value = "g" Then
Cells(i, "B") = "C"
ElseIf Cells(i, "A") = "C" Or Cells(i, "A").Value = "c" Then
Cells(i, "B") = "G"
ElseIf Cells(i, "A") <> "A" Or Cells(i, "A") <> "a" Or Cells(i, "A") <> "T" Or Cells(i, "A") <> "t" Or Cells(i, "A") <> "G" Or Cells(i, "A") <> "g" Or Cells(i, "A") <> "C" Or Cells(i, "A") <> "c" Then
MsgBox "You have mis typed your DNA sequence"
End If
i = i + 1
Loop
Do While Cells(i, "B").Value <> ""
'X Block
If Cells(i, "B").Value = "U" Then
GoTo U1:
ElseIf Cells(i, "B").Value = "C" Then
GoTo C1:
ElseIf Cells(i, "B").Value = "A" Then
GoTo A1:
ElseIf Cells(i, "B").Value = "G" Then
GoTo G1:
End If
'UX Block
U1:
If Cells(i + 1, "B").Value = "U" Then
GoTo UU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo UC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo UA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo UG2:
End If
'UUX Block
UU2:
If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Phe"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Leu"
End If
GoTo EndOfAcids:
'UCX Block
UC2:
Cells(a, "C").Value = "Ser"
GoTo EndOfAcids:
'UAX Block
UA2:
If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Tyr"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Stop Codon"
End If
GoTo EndOfAcids:
'UGX Block
UG2:
If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Cys"
ElseIf Cells(i + 2, "B").Value = "A" Then
Cells(a, "C").Value = "Stop Codon"
ElseIf Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Trp"
End If
GoTo EndOfAcids:
'CX Block
C1:
If Cells(i + 1, "B").Value = "U" Then
GoTo CU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo CC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo CA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo CG2:
End If
'CUX Block
CU2:
Cells(a, "C").Value = "Leu"
GoTo EndOfAcids:
'CCX Block
CC2:
Cells(a, "C").Value = "Pro"
GoTo EndOfAcids:
'CAX Block
CA2:
If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "His"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Gln"
End If
GoTo EndOfAcids:
'CGX Block
CG2:
Cells(a, "C").Value = "Arg"
GoTo EndOfAcids:
'AX Block
A1:
If Cells(i + 1, "B").Value = "U" Then
GoTo AU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo AC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo AA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo AG2:
End If
'AUX Block
AU2:
If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Or Cells(i + 2).Value = "A" Then
Cells(a, "C").Value = "Ile"
ElseIf Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Met"
End If
GoTo EndOfAcids:
'ACX Block
AC2:
Cells(a, "C").Value = "Thr"
GoTo EndOfAcids:
'AAX Block
AA2:
If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Asn"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Lys"
End If
GoTo EndOfAcids:
'AGX Block
AG2:
If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Ser"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Arg"
End If
GoTo EndOfAcids:
'GX Block
G1:
If Cells(i + 1, "B").Value = "U" Then
GoTo GU2:
ElseIf Cells(i + 1, "B").Value = "C" Then
GoTo GC2:
ElseIf Cells(i + 1, "B").Value = "A" Then
GoTo GA2:
ElseIf Cells(i + 1, "B").Value = "G" Then
GoTo GG2:
End If
'GUX Block
GU2:
Cells(a, "C").Value = "Val"
GoTo EndOfAcids:
'GCX Block
GC2:
Cells(a, "C").Value = "Ala"
GoTo EndOfAcids:
'GAX Block
GA2:
If Cells(i + 2, "B").Value = "U" Or Cells(i + 2, "B").Value = "C" Then
Cells(a, "C").Value = "Asp"
ElseIf Cells(i + 2, "B").Value = "A" Or Cells(i + 2, "B").Value = "G" Then
Cells(a, "C").Value = "Glu"
GoTo EndOfAcids:
'GGX Block
GG2:
Cells(a, "C").Value = "Gly"
GoTo EndOfAcids:
EndOfAcids:
i = i + 3
a = a + 1
Loop
End Sub
Related
I have a Excel Table in which I'd like to add new line if condition meet. Actually my code is working partly. It adds lines but when the work finish Debug appears (Run-time error 13, type mismatch).
I am in trouble if sometimes unexpected error happens. So please help me make my code more advance and work properly.
Sub AddWorkingYearLine2()
Dim i As Long
With Worksheets("DB")
For i = Cells(Rows.Count, "A").End(xlUp).Row To 4 Step -1
'make sure it's not an "old entry"
If Cells(i, "A").Value2 <> Cells(i + 1, "A").Value2 Then
'if today occurs after "end date" then
If Range("D1") > CDate(Cells(i, "F").Value) And Len(Cells(i, "F").Value2) > 0 Then
'insert row
Rows(i + 1).Insert Shift:=xlShiftDown
'copy row down
'Rows(i + 1).Value = Rows(i).Value
'update dates
Cells(i + 1, "A").Value = Cells(i, "A").Value
Cells(i + 1, "B").Value = Cells(i, "B").Value
Cells(i + 1, "C").Value = Cells(i, "C").Value
Cells(i + 1, "D").Value = Cells(i, "D").Value
Cells(i + 1, "E").Value = Cells(i, "F").Value
Cells(i + 1, "F").Value = DateAdd("yyyy", 1, CDate(Cells(i + 1, "E").Value))
Cells(i + 1, "G").Value = Cells(i, "M").Value
Cells(i + 1, "H").Value = Cells(i, "H").Value
Cells(i + 1, "I").Value = Cells(i, "I").Value
Cells(i + 1, "J").Value = Cells(i, "J").Value
Application.CutCopyMode = False
End If
End If
Next i
End With
End Sub
you're using With Worksheets("DB") but then you're not referencing all range objects to Worksheets("DB") object since you're not using dots...
Dim i As Long
With Worksheets("DB")
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 4 Step -1
'make sure it's not an "old entry"
If .Cells(i, "A").Value2 <> .Cells(i + 1, "A").Value2 Then
'if today occurs after "end date" then
If .Range("D1") > CDate(.Cells(i, "F").Value) And Len(.Cells(i, "F").Value2) > 0 Then
'insert row
.Rows(i + 1).Insert Shift:=xlShiftDown
'copy row down
'Rows(i + 1).Value = Rows(i).Value
'update dates
.Cells(i + 1, "A").Value = .Cells(i, "A").Value
.Cells(i + 1, "B").Value = .Cells(i, "B").Value
.Cells(i + 1, "C").Value = .Cells(i, "C").Value
.Cells(i + 1, "D").Value = .Cells(i, "D").Value
.Cells(i + 1, "E").Value = .Cells(i, "F").Value
.Cells(i + 1, "F").Value = DateAdd("yyyy", 1, CDate(.Cells(i + 1, "E").Value))
.Cells(i + 1, "G").Value = .Cells(i, "M").Value
.Cells(i + 1, "H").Value = .Cells(i, "H").Value
.Cells(i + 1, "I").Value = .Cells(i, "I").Value
.Cells(i + 1, "J").Value = .Cells(i, "J").Value
Application.CutCopyMode = False
End If
End If
Next
End With
Every week in work I have a file of around 15000 customers that I need to break up into two categories based on their names. My current code works but it loops through every row taking almost 3 minutes to run. What would be the best way to improve the speed - I'm assuming there are much more efficient methods than the lengthy if statement I've used?
Option Compare Text
Private Sub CommandButton1_Click()
Dim i As Long
Application.ScreenUpdating = False
For i = 2 To Rows.Count
If Cells(i, 33).Value = "Business" Then
Cells(i, 32).Value = "B"
ElseIf Cells(i, 33).Value = "Personal" Then
Cells(i, 32).Value = "P"
ElseIf Cells(i, 12).Value = "N" Then
Cells(i, 32).Value = "B"
ElseIf Cells(i, 12).Value = "Y" Then
Cells(i, 32).Value = "P"
ElseIf Cells(i, 20).Value = "PREMIER" Then
Cells(i, 32).Value = "P"
ElseIf InStr(1, Cells(i, 4), "LTD") <> 0 Then 'Finds each word in customer name, column D, and enters it as business customer
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "LIMITED") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "MANAGE") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "BUSINESS") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "CONSULT") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "INTERNATIONAL") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "T/A") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "TECH") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "CLUB") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "OIL") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "SERVICE") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "SOLICITOR") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf Cells(i, 4).Value = "UIT" Then
Cells(i, 32).Value = "B"
Else
Cells(i, 32).Value = ""
End If
Next i
Application.ScreenUpdating = True
End Sub
If you want to speed up the process, I'd stop using VBA, but write a formula instead.
Example: for finding if a cell equals "Business" or "N", you can use something like this:
=IF(OR(A1="Business";A2="N");"B";"P")
For finding if a cell contains "Business", you can use something like this:
=IF(FIND("Business";A1);"B";"P")
Combining all of this using the OR() worksheet function, you can get the whole thing. Obviously you'll need to drag your formula over your the entire column within your worksheet.
Try
Private Sub CommandButton1_Click()
Dim i As Long, r As Long
Dim vDB As Variant
Dim Ws As Worksheet
Dim rngDB As Range
Set Ws = ActiveSheet
Set rngDB = Ws.UsedRange
vDB = rngDB
r = UBound(vDB, 1)
For i = 2 To r
If vDB(i, 33) = "Business" Then
vDB(i, 32) = "B"
ElseIf vDB(i, 33) = "Personal" Then
vDB(i, 32) = "P"
ElseIf vDB(i, 12) = "N" Then
vDB(i, 32) = "B"
ElseIf vDB(i, 12) = "Y" Then
vDB(i, 32) = "P"
ElseIf vDB(i, 20) = "PREMIER" Then
vDB(i, 32) = "P"
ElseIf InStr(1, vDB(i, 4), "LTD") <> 0 Then 'Finds each word in customer name, column D, and enters it as business customer
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "LIMITED") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "MANAGE") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "BUSINESS") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "CONSULT") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "INTERNATIONAL") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "T/A") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "TECH") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "CLUB") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "OIL") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "SERVICE") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "SOLICITOR") <> 0 Then
vDB(i, 32) = "B"
ElseIf vDB(i, 4) = "UIT" Then
vDB(i, 32) = "B"
Else
vDB(i, 32) = ""
End If
Next i
rngDB = vDB
End Sub
I have a macro, that start from i, and ends at n. n is the end of the dynamic range. The macro adds rows and enters data based on various criterias. The code works very fine, but it only covers 85% of the total range before 'n' ends.
see code below:
Sub AddExtrasFerry()
Dim i As Long
Dim n As Long
n = Sheets("Original").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Original").Select
For i = 10 To n
If Cells(i, 16).Value <> "" And Cells(i, 3).Value Like "Wood*" And Cells(i, 16).Value = 100 Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = 100
Cells(i + 1, 1).Value = 20430
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
ElseIf Cells(i, 16).Value <> "" And Cells(i, 3).Value Like "Wood*" And Cells(i, 16).Value > 100 Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = 100
Cells(i + 1, 1).Value = 20430
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
Cells(i + 2, 16).EntireRow.Insert
Cells(i + 2, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 2, 6).Value = Cells(i, 16).Value - 100
Cells(i + 2, 1).Value = 20305
Cells(i + 2, 11).Value = ""
Cells(i + 2, 12).Value = ""
Cells(i + 2, 15).Value = ""
Cells(i + 2, 16).Value = ""
i = i + 1
n = Sheets("Original").Cells(Rows.Count, "A").End(xlUp).Row
ElseIf Cells(i, 16).Value <> "" Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = Cells(i, 16).Value
Cells(i + 1, 1).Value = 20305
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
i = i + 1
n = Sheets("Original").Cells(Rows.Count, "A").End(xlUp).Row
End If
Next i
End Sub
If you add or delete rows you need to loop backwards or you'll mess up your indexing, try this:
Sub AddExtrasFerry()
Dim i As Long
Dim n As Long
n = Sheets("Original").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Original").Select
For i = n To 10 step - 1
If Cells(i, 16).Value <> "" And Cells(i, 3).Value Like "Wood*" And Cells(i, 16).Value = 100 Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = 100
Cells(i + 1, 1).Value = 20430
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
ElseIf Cells(i, 16).Value <> "" And Cells(i, 3).Value Like "Wood*" And Cells(i, 16).Value > 100 Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = 100
Cells(i + 1, 1).Value = 20430
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
Cells(i + 2, 16).EntireRow.Insert
Cells(i + 2, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 2, 6).Value = Cells(i, 16).Value - 100
Cells(i + 2, 1).Value = 20305
Cells(i + 2, 11).Value = ""
Cells(i + 2, 12).Value = ""
Cells(i + 2, 15).Value = ""
Cells(i + 2, 16).Value = ""
ElseIf Cells(i, 16).Value <> "" Then
Cells(i + 1, 16).EntireRow.Insert
Cells(i + 1, 1).EntireRow.Value = Cells(i, 1).EntireRow.Value
Cells(i + 1, 6).Value = Cells(i, 16).Value
Cells(i + 1, 1).Value = 20305
Cells(i + 1, 11).Value = ""
Cells(i + 1, 12).Value = ""
Cells(i + 1, 15).Value = ""
Cells(i + 1, 16).Value = ""
End If
Next i
End Sub
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 7 years ago.
Improve this question
I really need help with this project that I am working on but I cannot seem to get this error off my back. Could anyone please recommend solutions ?
Sub Dsurvey()
Dim i As Integer
Dim j As Integer
Dim k As Integer
k = 3
For i = 3 To 22
j = j + 1
If Sheets("2").Cells(j, "A").Value - Sheets("2").Cells(i, "A").Value = Sheets("2").Cells(j, "B").Value - Sheets("2").Cells(i, "B").Value Then
Sheets("2").Cells(k, "J").Value = Sheets("2").Cells(i, "A").Value
Sheets("2").Cells(k, "K").Value = Sheets("2").Cells(i, "B").Value
Do While Sheets("2").Cells(k, "J").Value <= Sheets("2").Cells(j, "A").Value
Sheets("2").Cells(k, "J").Value = Sheets("2").Cells(k - 1, "J").Value + 100
Sheets("2").Cells(k, "K").Value = Sheets("2").Cells(k - 1, "K").Value + 100
k = k + 1
End If
Next i
End Sub
It isn't so much that you are missing an End If , but you are not closing the Do While with a Loop.
k = 3
For i = 3 To 22
j = j + 1
If Sheets("2").Cells(j, "A").Value - Sheets("2").Cells(i, "A").Value = Sheets("2").Cells(j, "B").Value - Sheets("2").Cells(i, "B").Value Then
Sheets("2").Cells(k, "J").Value = Sheets("2").Cells(i, "A").Value
Sheets("2").Cells(k, "K").Value = Sheets("2").Cells(i, "B").Value
Do While Sheets("2").Cells(k, "J").Value <= Sheets("2").Cells(j, "A").Value
Sheets("2").Cells(k, "J").Value = Sheets("2").Cells(k - 1, "J").Value + 100
Sheets("2").Cells(k, "K").Value = Sheets("2").Cells(k - 1, "K").Value + 100
k = k + 1
Loop
End If
Next i
Debug version:
k = 3
With Sheets("2")
For i = 3 To 22
j = j + 1
If IsNumeric(.Cells(j, "A")) And IsNumeric(.Cells(i, "A")) And IsNumeric(.Cells(j, "B")) And IsNumeric(.Cells(i, "B")) Then
If .Cells(j, "A").Value - .Cells(i, "A").Value = .Cells(j, "B").Value - .Cells(i, "B").Value Then
.Cells(k, "J").Value = .Cells(i, "A").Value
.Cells(k, "K").Value = .Cells(i, "B").Value
Do While .Cells(k, "J").Value <= .Cells(j, "A").Value
.Cells(k, "J").Value = .Cells(k - 1, "J").Value + 100
.Cells(k, "K").Value = .Cells(k - 1, "K").Value + 100
k = k + 1
Loop
End If
Else
Debug.Print "Not numeric: & " & i & Chr(45) & j & Chr(45) & k
End If
Next i
End With
I would need a code to program in adding new rows when there is an empty rows in between occupied rows.
For example, there is an empty row between the first and third occupied row.
Thus, i would need a code to program and insert information into the empty row in between the occupied rows using VBA user form.
I managed to create some coding but it seems not to be able to work. I hope anyone could help me.
Thank you.
Private Sub CommandAddButton1_Click()
lastrow = Sheets("Programme Status Summary").Range("J" & Rows.Count).End(xlUp).Row
Cells(lastrow + 1, "J").Value = TextBoxProjCode.Text
Cells(lastrow + 1, "E").Value = TextBoxProjName.Text
Cells(lastrow + 1, "C").Value = TextBoxSegment.Text
Cells(lastrow + 1, "F").Value = TextBoxSummary.Text
Cells(lastrow + 1, "G").Value = TextBoxAcc1.Text
Cells(lastrow + 1, "H").Value = TextBoxAcc2.Text
Cells(lastrow + 1, "I").Value = TextBoxProjM.Text
Cells(lastrow + 1, "K").Value = TextBoxCountry.Text
Cells(lastrow + 1, "L").Value = TextBoxRegulatory.Text
Cells(lastrow + 1, "M").Value = TextBoxRiskLvl.Text
Cells(lastrow + 1, "P").Value = TextBoxSchForecast.Text
Cells(lastrow + 1, "R").Value = TextBoxSchPar.Text
Cells(lastrow + 1, "S").Value = TextBoxImpact.Text
Cells(lastrow + 1, "T").Value = TextBoxCustNonRetail.Text
Cells(lastrow + 1, "U").Value = TextBoxCustRetail.Text
Cells(lastrow + 1, "V").Value = TextBoxOutsourcingImp.Text
Cells(lastrow + 1, "W").Value = TextBoxListImpt.Text
Cells(lastrow + 1, "X").Value = TextBoxKeyStatus.Text
Cells(lastrow + 1, "N").Value = TextBoxSchStart.Text
Cells(lastrow + 1, "O").Value = TextBoxSchEnd.Text
Cells(lastrow + 1, "Y").Value = TextBoxRagStatus.Text
Cells(lastrow + 1, "Z").Value = TextBoxRagCost.Text
Cells(lastrow + 1, "AA").Value = TextBoxRagBenefit.Text
End Sub
Using your code as basis, you'd need to add a loop, to find those line:
Private Sub CommandAddButton1_Click()
dim lngLastRow as Long
dim i as integer
dim wksWork as worksheet
set wksWork = thisworkbook.worksheets("Programme Status Summary")
lngLastRow = wksWork.Range("J" & wksWork.Rows.Count).End(xlUp).Row
for i = 1 to lngLastRow 'This starts in row 1, adjust accordingly
if wkswork.cells(i,1).value="" or wksWork.cells(i,1).value = vbNullstring then 'Checks in column A if there is any value given
with wksWork
.Cells(i, "J").Value = TextBoxProjCode.Text
.Cells(i, "E").Value = TextBoxProjName.Text
.Cells(i, "C").Value = TextBoxSegment.Text
.Cells(i, "F").Value = TextBoxSummary.Text
.Cells(i, "G").Value = TextBoxAcc1.Text
.Cells(i, "H").Value = TextBoxAcc2.Text
.Cells(i, "I").Value = TextBoxProjM.Text
.Cells(i, "K").Value = TextBoxCountry.Text
.Cells(i, "L").Value = TextBoxRegulatory.Text
.Cells(i, "M").Value = TextBoxRiskLvl.Text
.Cells(i, "P").Value = TextBoxSchForecast.Text
.Cells(i, "R").Value = TextBoxSchPar.Text
.Cells(i, "S").Value = TextBoxImpact.Text
.Cells(i, "T").Value = TextBoxCustNonRetail.Text
.Cells(i, "U").Value = TextBoxCustRetail.Text
.Cells(i, "V").Value = TextBoxOutsourcingImp.Text
.Cells(i, "W").Value = TextBoxListImpt.Text
.Cells(i, "X").Value = TextBoxKeyStatus.Text
.Cells(i, "N").Value = TextBoxSchStart.Text
.Cells(i, "O").Value = TextBoxSchEnd.Text
.Cells(i, "Y").Value = TextBoxRagStatus.Text
.Cells(i, "Z").Value = TextBoxRagCost.Text
.Cells(i, "AA").Value = TextBoxRagBenefit.Text
end with
end if
next i
End Sub