I'am trying to implement a code so that all the number of words from each cell in a column can be calculated and displayed in a cell just next to them.
I have written this code, but it shows Complie Error: Loop without Do, where as I'am having it.
Sub Command()
total_words = 1
Dim ans_length As Integer
Dim start_point As Integer
Range("N3").Select
Do Until ActiveCell.Value = ""
ans_length = Len(ActiveCell.Offset(0, 13).Value)
For start_point = 1 To ans_length
If (Mid(ans_length, start_point, 1)) = " " Then
total_words = total_words + 1
End If
ActiveCell.Offset(0, 12).Value = total_words
ActiveCell.Offset(1, 0).Select
Loop
End Sub
say i have this content:
Col1 Col2
The only way to do multi | 6
line comments in VB | 4
the only option you have | 5
is the single | 3
here i have col2 by default and writing VBA code for col2
This UDF approach would be an easier option ... well ... in my opinion anyway.
Public Function CountWords(ByVal strText As String) As Long
Application.Volatile
CountWords = UBound(Split(strText, " ")) + 1
End Function
... you can then use that in any cell.
If you want to go with your original approach, you were missing a NEXT.
Sub Command()
total_words = 1
Dim ans_length As Integer
Dim start_point As Integer
Range("N3").Select
Do Until ActiveCell.Value = ""
ans_length = Len(ActiveCell.Offset(0, 13).Value)
For start_point = 1 To ans_length
If (Mid(ans_length, start_point, 1)) = " " Then
total_words = total_words + 1
End If
Next start_point
ActiveCell.Offset(0, 12).Value = total_words
ActiveCell.Offset(1, 0).Select
Loop
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 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
Trying to loop through a sheets"data".Range"AM1:AS12" and copy the data to range beginning at BD1 as long as the data doesn't equal "#N/A"
My code works with copying the first column, but doesn't do anything with the data after that. Where am I going wrong?
Set S2 = Sheets("data").Range("AM:AM")
Set S3 = Sheets("data").Range("BD:BD")
Dim i As Integer, j As Integer
j = 1
For i = 1 To 12
If S2.Cells(i, 1).Value <> "#N/A" Then
S3.Cells(j, 2).Value = S2.Cells(i, 1).Value
j = j + 1
End If
Next i
Replace:
<> "#N/A"
By:
Not(Application.WorksheetFunction.IfNa(...))
This works when i tested it.
Sub CopyCell()
Set S2 = Sheets("data").Range("A:A")
Set S3 = Sheets("data").Range("M:M")
Dim i As Integer, j As Integer
For j = 1 To 2
For i = 1 To 12
If S2.Cells(i, j).Value <> "#N/A" Then
S3.Cells(i, j).Value = S2.Cells(i, j).Value
End If
Next i
Next j
Call DeleteBlank
End Sub
Sub DeleteBlank()
Dim x As Integer
Dim y As Integer
For y = 13 To 16 'Range numbers for the columns the data is copied to
For x = 1 To 10 ' Number of cells of data you want to loop through
If Cells(x, y).Value = "" Then
Cells(x, y).Delete Shift:=xlUp
End If
Next x
Next y
End Sub
the best thing to is not to check if it is equal to "#N/A"
The best is to check if it is an error : If Not (IsError(S2.Cells(i, 1).Value)) Then
I have the following issue: In one workbook I have multiple sheets.
On Sheet 2 in column "D" starting on row 2, Is a list of 300+ prefixes of 4 digits long e.g. XFTZ, GHTU, ZAQS etc.
On Sheet 1 in column "R" starting on row 3, Is a list of 1000+ values that can have the following values e.g.: AAAA1234556 and ZAQS12565865.
The first value AAAA...... is allowed, where the second value ZAQS..... Should throw an error message when running the VBA code.
The list of values in both sheets can grow over time, so I would like to avoid hard coding of records. I would expect best solution here is to use something like this:
LastRowNr = Cells(Rows.Count, 1).End(xlUp).Row
Try something like the following, replacing Sheet1 with the name in which the actual data is located
Option Explicit
Private Sub searchPrefix()
Dim RangeInArray() As Variant
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim tmpSrch As String
Dim i As Long
LastRow1 = Worksheets("Sheet1").Cells(Rows.Count, 18).End(xlUp).Row
LastRow2 = Worksheets("PREFIXES").Cells(Rows.Count, 4).End(xlUp).Row
RangeInArray = Application.Transpose(Worksheets("PREFIXES").Range("D1:D" & LastRow2).Value)
For i = 3 To LastRow1
If Len(Worksheets("Sheet1").Cells(i, 18).Value) >= 3 Then
tmpSrch = Left(Worksheets("Sheet1").Cells(i, 18).Value, 4) '18: column R
If IsInArray(tmpSrch, RangeInArray) Then
Worksheets("Sheet1").Cells(i, 18).Interior.ColorIndex = xlNone
Worksheets("Sheet1").Cells(i, 18).Font.ColorIndex = 0
Worksheets("Sheet1").Cells(i, 18).Font.Bold = False
Else
Worksheets("Sheet1").Cells(i, 18).Interior.Color = RGB(252, 134, 75)
Worksheets("Sheet1").Cells(i, 18).Font.Color = RGB(181, 24, 7)
Worksheets("Sheet1").Cells(i, 18).Font.Bold = True
End If
End If
Next
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Option Explicit
Sub searchPrefix()
Sheets("PREFIXES").Select
Dim CellCntnt As String
Dim tmpSrch As String
Dim isFound As Boolean
isFound = False
Dim QtySrchChar As Integer
QtySrchChar = 4
Dim Cnt As Integer
Cnt = 0
Dim Tag As Integer
Cells.Range("A1").Select
Do Until IsEmpty(ActiveCell)
Cnt = Cnt + 1
ActiveCell.Offset(1, 0).Select
Loop
For Tag = 1 To Cnt - 1
CellCntnt = Cells(1 + i, 1).Value
tmpSrch = Left(CellCntnt, QtySrchChar)
Cells.Range("G1").Select
Do Until IsEmpty(ActiveCell)
If Left(ActiveCell.Value, QtySrchChar) = tmpSrch Then
QtySrchChar = QtySrchChar + 1
tmpSrch = Left(CellCntnt, QtySrchChar)
isFound = True
MsgBox ("True Tags introduced with Std.Prefix " & tmpSrch)
End If
If isFound Then
isFound = False
MsgBox ("False Tags introduced with Std.Prefix " & tmpSrch)
Cells.Range("G1").Select
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
Next Tag
End Sub
I am using this code to transfer data from one sheet to another. The code allows for the data being transferred to stay on the new sheet until deleted.
Private Sub Transfer2_Click()
Dim Work_Order1 As String, Qty1 As Integer, Frame1 As String, Qty_Frame1 As Integer
Worksheets("Work_Order").Select
if Worksheets("Work_Order").Range("C12") = "" Then Exit Sub
Work_Order1 = Range("N3")
Qty1 = Range("B3")
Frame1 = Range("C12").Value
Qty_Frame1 = Range("M12")
Worksheets("Order").Select
Worksheets("Order").Range("A4").Select
If Worksheets("Order").Range("A4").Offset(1, 0) <> "" Then
Worksheets("Order").Range("A4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Work_Order1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Qty1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Frame1
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = Qty_Frame1
Private Sub Transfer2_Click()
Dim Work_Order2 As String, Qty2 As Integer, Frame2 As String, Qty_Frame2 As Integer
Worksheets("Work_Order").Select
if Worksheets("Work_Order").Range("C13") = "" Then Exit Sub
Work_Order2 = Range("N3")
Qty2 = Range("B3")
Frame2 = Range("C13").Value
Qty_Frame2 = Range("M13")
Worksheets("Order").Select
Worksheets("Order").Range("A4").Select
If Worksheets("Order").Range("A4").Offset(1, 0) <> "" Then
Worksheets("Order").Range("A4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Work_Order2
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Qty2
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Frame2
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = Qty_Frame2
Private Sub Transfer2_Click()
Dim Work_Order3 As String, Qty3 As Integer, Frame3 As String, Qty_Frame3 As Integer
Worksheets("Work_Order").Select
if Worksheets("Work_Order").Range("C14") = "" Then Exit Sub
Work_Order1 = Range("N3")
Qty3 = Range("B3")
Frame3 = Range("C14").Value
Qty_Frame3 = Range("M14")
Worksheets("Order").Select
Worksheets("Order").Range("A4").Select
If Worksheets("Order").Range("A4").Offset(1, 0) <> "" Then
Worksheets("Order").Range("A4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Work_Order3
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Qty3
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Frame3
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = Qty_Frame3
What I am trying to do is end this code is no value is found in the "C" Range. I have the code repeated nine times because there are nine instances where this info can be found, but not all will have values all the time. If that occurs, I want it to end the code before transferring info to the new sheet.
so far I've tried:
if Worksheets("Work_Order").Range("C12")="" Then
Exit sub
But it returns with the error Block if without end if.
By putting the Exit Sub on a different line to the If, you are creating a "Block If", which needs an End If:
If Worksheets("Work_Order").Range("C12")="" Then
Exit sub
End If
If you want to use a "single-line If", you should put your statements on a single line:
If Worksheets("Work_Order").Range("C12")="" Then Exit sub
Both statements work in exactly the same way, but "block Ifs" are usually easier to code when you have multiple statements to be executed within either the True or False leg of the statement.
E.g.
If a = 5 Then
b = 7
c = 10 * a - b
d = 5 + b - c
Else
b = 9
c = 20 * a - 4 * b
d = 6 + b + c
End If
is easier to read than
If a = 5 Then b = 7: c = 10 * a - b: d = 5 + b - c Else b = 9: c = 20 * a - 4 * b: d = 6 + b + c
In response to your comments, I am guessing that you don't actually want to Exit Sub when you hit a blank value, you want to instead go on to process the next range.
This could be done like this:
Private Sub Transfer2_Click()
Dim Work_Order1 As String, Qty1 As Integer, Frame1 As String, Qty_Frame1 As Integer
If Worksheets("Work_Order").Range("C12").Value <> "" Then
Worksheets("Work_Order").Select
Work_Order1 = Range("N3")
Qty1 = Range("B3")
Frame1 = Range("C12").Value
Qty_Frame1 = Range("M12")
Worksheets("Order").Select
Worksheets("Order").Range("A4").Select
If Worksheets("Order").Range("A4").Offset(1, 0) <> "" Then
Worksheets("Order").Range("A4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Work_Order1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Qty1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Frame1
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = Qty_Frame1
End If
'Then repeat for the next set of cells
which can be rewritten to avoid the use of Select (which leads to so many problems) as
Private Sub Transfer2_Click()
Dim Work_Order1 As String, Qty1 As Integer, Frame1 As String, Qty_Frame1 As Integer
If Worksheets("Work_Order").Range("C12").Value <> "" Then
With Worksheets("Work_Order")
Work_Order1 = .Range("N3")
Qty1 = .Range("B3")
Frame1 = .Range("C12").Value
Qty_Frame1 = .Range("M12")
End With
With Worksheets("Order").Cells(Worksheets("Order").Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow
.Cells(1, "A").Value = Work_Order1
.Cells(1, "B").Value = Qty1
.Cells(1, "C").Value = Frame1
.Cells(1, "E").Value = Qty_Frame1
End With
End If
'Then repeat for the next set of cells
But it would be best if that was split into two subroutines to avoid a lot of repetitive code:
Private Sub Transfer2_Click()
With Worksheets("Work_Order")
Transfer2_Paste .Range("N3").Value, .Range("B3").Value, .Range("C12").Value, .Range("M12").Value
'Then repeat for the next set of cells, e.g.
'Transfer2_Paste .Range("N4").Value, .Range("B4").Value, .Range("C13").Value, .Range("M13").Value
'etc
End With
End Sub
Private Sub Transfer2_Paste(Work_Order1 As String, Qty1 As Integer, Frame1 As String, Qty_Frame1 As Integer)
If Frame1 = "" Then
Exit Sub
End If
With Worksheets("Order").Cells(Worksheets("Order").Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow
.Cells(1, "A").Value = Work_Order1
.Cells(1, "B").Value = Qty1
.Cells(1, "C").Value = Frame1
.Cells(1, "E").Value = Qty_Frame1
End With
End Sub