Do While Cells(i, 1).Value <> ""
....
End If
i = i + 1
Loop
End Sub
Right. It works fine with numbers and stop perfectly. But With Text. It does not stop.
Ideally I want to stop at the last row of my content rather than my last row in Excel. I manage to make it work fine with numbers, but I cannot fix it with Text.
Any help would be great as I am a beginner in VBA.
Sub checkRoutine()
Dim i As Integer
Dim LastRow As Long
i = 1
Do While Cells(i, 1).Value <> ""
If IsNumeric(Cells(i, 1).Value) Then Cells(i, 2).Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
If Not IsNumeric(Cells(i, 1).Value) Then
LastRow = Range("A" & Rows.Count).End(xlUp).row + 1
ActiveSheet.Cells(LastRow, "A").Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
End If
i = i + 1
Loop
End Sub
As suggested by so many people, you need to change to use a For loop:
Sub checkRoutine()
Dim i As Long
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).row
For i = 1 To LastRow
If IsNumeric(Cells(i, 1).Value) Then
Cells(i, 2).Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
Else
LastRow = Range("A" & Rows.Count).End(xlUp).row + 1
Cells(LastRow, "A").Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
End If
Next
End Sub
Related
Formula below just inserts the row and changing color for certain offset. I need to copy formula from previuos cells H, M, N. Any ideas?
Sub button()
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Range("D" & LastRow + 1).EntireRow.Insert
With Range("D" & Rows.Count).End(xlUp).Offset(1)
.Value = .Offset(-1).Value + 1
.Offset(, -1).Interior.ColorIndex = 0
.Offset(, -2).Interior.ColorIndex = 0
.Offset(, -3).Interior.ColorIndex = 0
End With
End Sub
So now it's working
Sub Prideti_produkta()
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Range("D" & LastRow + 1).EntireRow.Insert
Range("H" & LastRow + 1).FillDown
Range("K" & LastRow + 1).FillDown
Range("M" & LastRow + 1).FillDown
Range("N" & LastRow + 1).FillDown
With Range("D" & Rows.Count).End(xlUp).Offset(1)
.Value = .Offset(-1).Value + 1
.Offset(, -1).Interior.ColorIndex = 0
.Offset(, -2).Interior.ColorIndex = 0
.Offset(, -3).Interior.ColorIndex = 0
End With
End Sub
I am trying to reformat a text file that has been imported into Excel.
I have done several minor reformatting points including adding rows, deleting page numbers, and combining headlines back into a single cell via the & function (the text file was delimited when importing).
After a concatenate, in which I took certain cells from columns A-Z and combined them in Column A, I tried to delete the now redundant information from Columns B-Z.
I tried selecting the cells and deleting, and also Range.Clear, but it does not delete the cells. I receive no errors.
This is what I have to take care of this step:
'Fix Duplicate Cells from Concatenate
For i = lastRow2 To 2 Step -1
If IsEmpty(Range(i, 1).Offset(-1, 0)) = True Then
ActiveSheet.Range(Cells(i, 2), Cells(i, 26)).Clear
End If
Next
Ultimately, I would like to check if column A contains no information one row above the row where I would like to delete information from columns B-Z.
Full code:
Sub Format()
'This will delete page numbers
Dim lRow As Long
Dim iCntr As Long
lRow = 350
For iCntr = lRow To 1 Step -1
If IsNumeric(Cells(iCntr, 1)) Then
Rows(iCntr).Delete
End If
Next
'Add Row above each row with Headings
Dim lRow2 As Long, iRow As Long
With Worksheets("Sheet1")
lRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
'loop backwards (bottom to top = Step -1) through all rows
For iRow = lRow2 To 1 Step -1
'check if column A of current row (iRow) is "DIM"
If .Cells(iRow, "A").Value = "DIM" Then
.Rows(iRow).Resize(RowSize:=1).Insert xlShiftDown
'insert 1 row and move current (iRow) row down (xlShiftDown)
'means: insert 1 row ABOVE current row (iRow)
End If
Next iRow
End With
'Combine Headings back to single Cell
Dim lngLastRow As String
Dim lastRow As Long
Dim lastcolumn As Long
lastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
lastcolumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count
For i = lastRow To 1 Step -1
If Cells(i, 1).Value = "DIM" Then
Cells(i, 1).Value = Cells(i, 1).Value & " " & Cells(i, 2).Value & " " & _
Cells(i, 3).Value & " " & Cells(i, 4).Value & " " & Cells(i, 5).Value & " " & _
Cells(i, 6).Value & " " & Cells(i, 7).Value & " " & Cells(i, 8).Value & " " & _
Cells(i, 9).Value & " " & Cells(i, 10).Value & " " & Cells(i, 11).Value & " " & _
Cells(i, 12).Value & " " & Cells(i, 13).Value & " " & Cells(i, 14).Value & " " & _
Cells(i, 15).Value & " " & Cells(i, 16).Value & " " & Cells(i, 17).Value & " " & _
Cells(i, 18).Value & " " & Cells(i, 19).Value & " " & Cells(i, 20).Value & " " & _
Cells(i, 21).Value & " " & Cells(i, 22).Value & " " & Cells(i, 23).Value & " " & _
Cells(i, 24).Value & " " & Cells(i, 25).Value & " " & Cells(i, 25).Value
End If
Next
'Fix Duplicate Cells from Concatenate
For i = lastRow2 To 2 Step -1
If IsEmpty(Range(i, 1).Offset(-1, 0)) = True Then
ActiveSheet.Range(Cells(i, 2), Cells(i, 26)).Clear
End If
Next
End Sub
The reason I have a condition set for the clearing of cells after concatenate is because I do not simply want to clear all cells in range B:Z, or even the specific rows in this range. I only want to clear this range in the instances where there is a blank line above it (headers to data). The reason being: I am trying to keep the spreadsheet as generic as possible in order to use it again if the specific layout of rows changes based on the input file.
First, the variable lastRow2 doesn't seem to be declared, and as you don't get any errors, you obviously don't use Option Explicit. Please do, because that will warn you about such errors.
Secondly, I don't see that you in any way initialize lastRow2, which explains why the loop is never run. Did you run the code in the debugger to verify values of variables and progress of the execution? That is the first thing to do when you see unexpected results.
Thirdly, I don't understand why you have the condition and why you use offset If IsEmpty(Range(i, 1).Offset(-1, 0)) = True. Just clear the cells explicitly
Try this instead:
lastColumn = 26
For i = lastRow To 1 Step -1
Range(Cells(i, 2), Cells(i, lastColumn)).Clear
Next
edit:
I noticed you have the last column as 25 (as well as the previous one) in the part where you concatenate the values from the cells. The correct last column is 26.
edit2:
Based on your edit of your question and assuming you have declared and initialized lastRow2 the corrected function would look like this:
For i = lastRow2 To 2 Step -1
If IsEmpty(Range(Cells(i, 1), Cells(i, 1)).Offset(-1, 0)) = True Then
ActiveSheet.Range(Cells(i, 2), Cells(i, 4)).Clear
End If
Next
I have some problems with excel and VBA, in that don't know have much knowledge. I copied text from pdf and it's awful.
I have cells which contain some text.
The problem is that the text from one paragraph is broken down over several cells. At the beginning of each paragraph is a word in bold (e.g. CLR.) which describes the rest of the text. As such, it defines where each paragraph should start. How I can merge these cells into one?
I see
I want
Sub MergeText()
Dim strMerged$, r&, j&, i&
r = 1
Do While True
If Cells(r, 1).Characters(1, 1).Font.Bold Then
strMerged = "": strMerged = Cells(r, 1)
r = r + 1
While (Not Cells(r, 1).Characters(1).Font.Bold) And Len(Cells(r, 1)) > 0
strMerged = strMerged & Cells(r, 1)
r = r + 1
Wend
i = i + 1: Cells(i, 2) = strMerged
Cells(i, 2).Characters(1, InStr(1, strMerged, ".", vbTextCompare)).Font.Bold = True
Else
Exit Do
End If
Loop
End Sub
Modify (if needed) and try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, j As Long, Count As Long
Dim str As String
With ThisWorkbook.Worksheets("Sheet1") 'Change sheet name if needed
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
If (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) = Left(.Range("A" & i - 1), 1) Then
Count = 0
For j = 1 To Len(.Range("A" & i - 1))
If .Range("A1").Characters(j, 1).Font.FontStyle = "Bold" Then
Count = Count + 1
Else
Exit For
End If
Next j
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
With .Characters(Start:=1, Length:=Count).Font
.FontStyle = "Bold"
End With
End With
.Rows(i).EntireRow.Delete
ElseIf (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) <> Left(.Range("A" & i - 1), 1) Then
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
End With
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
I have a piece of code (VBA) that search through a sheet and finds matches then shows up the last matching row in some text boxes.
I put this code in a button,and want to make it to stop each time it finds an occurrence instead of finding the last one and stop.
here's the code:
Private Sub cmdFindNext_Click()
Dim lastrow
Dim myfname As String
lastrow = Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row
myfname = txtUsername.Text
For currentrow = 2 To lastrow
If Cells(currentrow, 3).Text Like "*" & myfname & "*" Then
txtHost.Text = Cells(currentrow, 2).Text
txtUsername.Text = Cells(currentrow, 3).Text
txtPassword.Text = Cells(currentrow, 4).Text
txtUser.Text = Cells(currentrow, 5).Text
txtDepartment.Text = Cells(currentrow, 6).Text
txtPosition.Text = Cells(currentrow, 7).Text
txtFormerusers.Text = Cells(currentrow, 8).Text
txtCompany.Text = Cells(currentrow, 9).Text
End If
Next currentrow
txtUsername.SetFocus
End Sub
I am not sure why you are using If .Cells(currentrow, 3).Text Like "*" & myfname & "*" Then since you are searching for wildcard, it will enter this If condition on every try.
The code below will execute one "find" on every click of the button, when you reach the end, it will restart. (you can remove it by modifying the first If startrow < 2 Or startrow >= lastrow Then)
Option Explicit
Public startrow As Long
Sub cmdFindNext_Click()
Dim lastrow As Long
Dim currentrow As Long
Dim myfname As String
With Sheets("Sheet2")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
' reset the start row if first run, or finished scanning entire range
If startrow < 2 Or startrow >= lastrow Then
startrow = 2
End If
myfname = txtUsername.Text
For currentrow = startrow To lastrow
If .Cells(currentrow, 3).Text Like "*" & myfname & "*" Then
txtHost.Text = .Cells(currentrow, 2).Text
txtUsername.Text = .Cells(currentrow, 3).Text
txtPassword.Text = .Cells(currentrow, 4).Text
txtUser.Text = .Cells(currentrow, 5).Text
txtDepartment.Text = .Cells(currentrow, 6).Text
txtPosition.Text = .Cells(currentrow, 7).Text
txtFormerusers.Text = .Cells(currentrow, 8).Text
txtCompany.Text = .Cells(currentrow, 9).Text
startrow = startrow + 1
Exit Sub
End If
Next currentrow
End With
txtUsername.SetFocus
End Sub
i have to sort data from sheet1 to sheet2 with reference to non-empty cell in column A. and
i have written code for it as below:
Sub polo()
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = Sheets("Sheet1").Cells(i - 1, 2).Value
j = j + 1
End If
Next i
End Sub
But the problem is, i am getting result as in column D of sheet2.
I want result as shown in column E.
Please help.
Try this version:
Sub polo()
Dim lastrow As Long
Dim sTemp as String
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = stemp
j = j + 1
Else
stemp = Sheets("Sheet1").Cells(i, 2).Value
End If
Next i
End Sub