Private Sub CalculateCharges()
Worksheets("Sheet1").Activate
Dim i As Long
Dim temp As String
RowCount = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Range("G1").Select
ActiveCell.Offset(1, 0).Select
i = 0
While i < RowsCount
If ActiveCell.Value Like "*W-M*" Then
ActiveCell.Offset(0, 8).Value = ActiveCell.Offset(0, 5).Value + ActiveCell.Offset(0, 6).Value
ActiveCell.Offset(1, 0).Select
End If
i = i + 1
Wend
End Sub
The above is my piece of code. Below is my excel look alike. How I can add up 2 values if a cell contain specific text value in it
You can simplify your code, without selecting each cell, which slows you down on large ranges.
You can also use InStr function as well
Private Sub CalculateCharges()
Dim sht1 As Excel.Worksheet
Set sht1 = ActiveWorkbook.Worksheets("Sheet1")
Dim i As Long
Dim temp As String
RowCount = sht1.UsedRange.Rows.Count
For i = 1 To RowCount
If sht1.Cells(i, 6).Value Like "*W-M*" Then
' can use the InStr function instead
'If InStr(1, sht1.Cells(i, 6).Value, "W-M", vbTextCompare) > 0 Then
sht1.Cells(i, 8).Value = sht1.Cells(i, 5).Value + sht1.Cells(i, 6).Value
End If
Next i
End Sub
Related
I am trying to copy a few colums of data that meet a certain criteria and then paste the first column of the copied data into a specific column on a second spreadsheet by nation. I am stuck selecting data from the copied cells- the second if statement.
New Working Code
Sub SortData()
'Clear Data from Practices Sheet
Sheet2.Range("B6:F1000").Clear
a = Worksheets("Home").Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To a
If Worksheets("Home").Cells(i, 4).Value = "Active" And Worksheets("Home").Cells(i, 3).Value = "Denmark" Then
C = Worksheets("Home").Cells(i, 2).Copy
Worksheets("Practices").Activate
b = Worksheets("Practices").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Practices").Cells(b + 1, 2).Select 'column To paste data into
ActiveSheet.Paste
Worksheets("Home").Activate
ElseIf Worksheets("Home").Cells(i, 4).Value = "Active" And Worksheets("Home").Cells(i, 3).Value = "Netherlands" Then
C = Worksheets("Home").Cells(i, 2).Copy
Worksheets("Practices").Activate
b1 = Worksheets("Practices").Cells(Rows.Count, 4).End(xlUp).Row
Worksheets("Practices").Cells(b1 + 1, 4).Select
ActiveSheet.Paste
Worksheets("Home").Activate
ElseIf Worksheets("Home").Cells(i, 4).Value = "Active" And Worksheets("Home").Cells(i, 3).Value = "UK" Then
C = Worksheets("Home").Cells(i, 2).Copy
Worksheets("Practices").Activate
b = Worksheets("Practices").Cells(Rows.Count, 6).End(xlUp).Row
Worksheets("Practices").Cells(b + 1, 6).Select
ActiveSheet.Paste
Worksheets("Home").Activate
End If
Next
End Sub
How to make this more concise?
I recommend to reduce redundant code like this:
Don't use .Select and .Activate as I told in my first comment.
How to avoid using Select in Excel VBA
Use Option Explicit to make sure all variables are declared.
Don't use the same code lines over and over. Instead make a function/procedure or reduce redundancy like I did below.
Always use descriptive variable names instead of one letter names. Otherwise your code is very hard to read/understand by humans.
Option Explicit
Public Sub SortData()
'Clear Data from Practices Sheet
Worksheets("Practices").Range("B6:F1000").Clear
Dim LastUsedRow As Long
LastUsedRow = Worksheets("Home").Cells(Rows.Count, 3).End(xlUp).Row
Dim i As Long
For i = 3 To LastUsedRow
If Worksheets("Home").Cells(i, 4).Value = "Active" Then
Dim PasteColumn As Long
Select Case Worksheets("Home").Cells(i, 3).Value
Case "Denmark": PasteColumn = 2
Case "Netherlands": PasteColumn = 4
Case "UK": PasteColumn = 6
Case Else: PasteColumn = 0 'we need this to cancel copy
End Select
If PasteColumn > 0 Then
Dim PasteLastRow As Long
PasteLastRow = Worksheets("Practices").Cells(Rows.Count, PasteColumn).End(xlUp).Row
Worksheets("Home").Cells(i, 2).Copy
Worksheets("Practices").Cells(PasteLastRow + 1, PasteColumn).Paste
End If
End If
Next i
End Sub
I have had a go at what i think you mean. But there are many errors and inconsistencies throughout as noted in the comments.
Sub SortData()
Dim a As Long, c As Range, sh As Worksheet, ws As Worksheet, b As Long
Set sh = ThisWorkbook.Sheets("Home")
Set ws = ThisWorkbook.Sheets("Practices")
a = sh.Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To a
If sh.Cells(i, 4).Value = "Active" Then
Set c = sh.Range(Cells(i, "A"), Cells(i, "D"))
End If
If c.Columns(3) = "Denmark" Then
b = ws.Cells(Rows.Count, 5).End(xlUp).Row
c.Copy
ws.Cells(i, 2).PasteSpecial
ElseIf c.Cells(i, 3) = "Netherlands" Then
b = ws.Cells(Rows.Count, 5).End(xlUp).Row
c.Copy
ws.Cells(i, 2).PasteSpecial
ElseIf C.Cells(i, 3) = "UK" Then
b = ws.Cells(Rows.Count, 5).End(xlUp).Row
c.Copy
ws.Cells(b + 1, 6).PasteSpecial
End If
Next
End Sub
I want to delete entire row when all 3 numeric values in cells in columns G,H,I are equal. I wrote a vba code and it does not delete nothing. can Someone advise?
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
Set rng = Range("G2", Range("G2").End(xlDown))
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = 2 To NumRows
Cells(i, 7).Select
If Cells(i, 7).Value = Cells(i, 8).Value = Cells(i, 9).Value Then
EntireRow.Delete
Else
Selection.Offset(1, 0).Select
End If
Next i
End Sub
Try this code. When deleting rows, always start from last row and work towards first one. That way you are sure you wont skip any row.
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = NumRows + 1 To 2 Step -1
If Cells(i, 7).Value = Cells(i, 8).Value And Cells(i, 7).Value = Cells(i, 9).Value Then
Cells(i, 7).EntireRow.Delete
Else
End If
Next i
End Sub
Remember when you delete rows, all you need to loop in reverse order.
Please give this a try...
Sub remove_dup()
Dim NumRows As Long
Dim i As Long
NumRows = Cells(Rows.Count, "G").End(xlUp).Row
For i = NumRows To 2 Step -1
If Application.CountIf(Range(Cells(i, 7), Cells(i, 9)), Cells(i, 7)) = 3 Then
Rows(i).Delete
End If
Next i
End Sub
You can delete all rows together using UNION. Try this
Sub remove_dup()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim cel As Range, rng As Range
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row 'last row with data in Column G
For i = lastRow To 2 Step -1 'loop from bottom to top
If .Range("G" & i).Value = .Range("H" & i).Value And .Range("G" & i).Value = .Range("I" & i).Value Then
If rng Is Nothing Then 'put cell in a range
Set rng = .Range("G" & i)
Else
Set rng = Union(rng, .Range("G" & i))
End If
End If
Next i
End With
rng.EntireRow.Delete 'delete all rows together
End Sub
I have this code that deletes a row if it has empty cells in columns D to L.
For some reason it is also deleting my title cell which is located at C8.
Anyone knows why? And how to fix it?
Sub RemoveEmptyRows()
Dim ws As Worksheet
For Each ws In Sheets
ws.Activate
Dim n As Long
Dim nlast As Long
Dim rw As Range
Set rw = ActiveWorkbook.ActiveSheet.UsedRange.Rows
nlast = rw.count
For n = nlast To 1 Step -1
If (rw.Cells(n, 4).Value = "" And rw.Cells(n, 5).Value = "" And rw.Cells(n, 6).Value = "" And rw.Cells(n, 7).Value = "" And rw.Cells(n, 8).Value = "" And rw.Cells(n, 9).Value = "" And rw.Cells(n, 10).Value = "" And rw.Cells(n, 11).Value = "") Then
rw.Rows(n).Delete
End If
Next n
Next ws
End Sub
The issue is that you are using the row and column indexes of UsedRange with the assumption that they match the indexes of the Worksheet. This isn't necessarily the case. As you pointed out to #YowE3K in the comments, you have some completely empty columns.
The solution is pretty easy - just use the ws.Cells instead of rw.Cells. I'd also throw everything inside the loop into a With block to make it faster and more readable. You can also short-circuit that long If statement by converting it into a Select Case ladder:
Sub RemoveEmptyRows()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
With ws
Dim n As Long
Dim nlast As Long
nlast = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For n = nlast To 9 Step -1
Select Case False
Case .Cells(n, 4).Value = vbNullString
Case .Cells(n, 5).Value = vbNullString
Case .Cells(n, 6).Value = vbNullString
Case .Cells(n, 7).Value = vbNullString
Case .Cells(n, 8).Value = vbNullString
Case .Cells(n, 9).Value = vbNullString
Case .Cells(n, 10).Value = vbNullString
Case .Cells(n, 11).Value = vbNullString
Case Else
.Rows(n).Delete
End Select
Next n
End With
Next ws
End Sub
Note that there are also more reliable ways to find the last row of the sheet.
your Title is in C8, then don't delete until Row number 1 :
replace
For n = nlast To 1 Step -1
by
For n = nlast To 9 Step -1
Here is your code a little amended.
Sub RemoveEmptyRows()
Dim ws As Worksheet
Dim n As Long
Dim nlast As Long
Dim rw As Range
For Each ws In Worksheets 'changed. In case there are Chart Sheets.
'deleted ws.activate. AVOID THAT AS PLAGUE
Set rw = ws.UsedRange.Rows
With rw
nlast = .Count
For n = nlast To 2 Step -1 'Note the 2, to skip title row. As was pointed in comments.
If (.Cells(n, 4).Value2 = "" And .Cells(n, 5).Value2 = "" And .Cells(n, 6).Value2 = "" And .Cells(n, 7).Value2 = "" And .Cells(n, 8).Value2 = "" And .Cells(n, 9).Value2 = "" And .Cells(n, 10).Value2 = "" And .Cells(n, 11).Value2 = "") Then
.Rows(n).Delete
End If
Next n
End With 'rw
Next ws
End Sub
You could try this (not tested) code:
Sub RemoveEmptyRows()
Dim ws As Worksheet
Dim nCols As Long
For Each ws In Sheets
With Intersect(.Range("D:K"), .UsedRange)
nCols = .Columns.Count
With .SpecialCells(xlCellTypeBlanks)
For iArea = .Areas.Count To 1 Step -1
If .Areas(iArea).Count = nCols Then .Areas(iArea).EntireRow.Delete
Next
End With
End With
Next ws
End Sub
I am trying to run the below code. But it is showing the error of Subscript out of range. When I tried to debug it, it is showing error in the 5 line: Range(“A1”).Select
While debugging, when I made the Sheet1 of 4th line as Sheet2, then it is not going on Sheet2.
Please help me run the code properly.
Sub excelmacro()
Application.ScreenUpdating = False
Sheets(“Sheet1”).Select
Range(“A1”).Select
Sheets(“Sheet2”).Select
Range(“A2”).Select
For i = 1 To 3
Sheets(“Sheet1”).Select
If Len(ActiveCell.Value) > 1 Then
Sheets(“Sheet1”).Select
Xname = Right(ActiveCell.Value, Len(ActiveCell.Value) - 6)
Xdesig = Right(ActiveCell.Offset(1, 0).Value, Len(ActiveCell.Offset(1, 0).Value) - 13)
Xsalary = Right(ActiveCell.Offset(2, 0).Value, Len(ActiveCell.Offset(2, 0).Value) - 8)
Sheets(“Sheet2”).Select
ActiveCell.Value = Xname
ActiveCell.Offset(0, 1).Value = Xdesig
ActiveCell.Offset(0, 2).Value = Xsalary
ActiveCell.Offset(1, 0).Select
Sheets(“Sheet1”).Select
ActiveCell.Offset(3, 0).Select
Else
i = 10
End If
i = i - 1
Next
Application.ScreenUpdating = True
End Sub
The quotation marks are oddball and create an error, but even after changing to 'normal' quoates there is a Subscript out of range error:
Instead of using Sheets, try Worksheets:
Worksheets("Sheet1").Select
To summarize my comments:
The double-quotes in the original code are oddly formatted. Use Notepad or the VBA IDE to replace them with appropriate plain text double quotes.
Be sure to declare your variables before using them if Option Explicit is turned on. Also just a good practice to follow even if it were not on.
(To be updated when I have more time this evening) Avoid making selections and usingActiveCell/ActiveSheet references.
With minor changes to your code it should look like this:
Sub excelmacro()
Dim i As Double, _
Xname As String, _
Xdesig As String, _
Xsalary As String
Application.ScreenUpdating = False
Sheets("Sheet1").Select
Range("A1").Select
Sheets("Sheet2").Select
Range("A2").Select
For i = 1 To 3
Sheets("Sheet1").Select
If Len(ActiveCell.Value) > 1 Then
Sheets("Sheet1").Select
Xname = Right(ActiveCell.Value, Len(ActiveCell.Value) - 6)
Xdesig = Right(ActiveCell.Offset(1, 0).Value, Len(ActiveCell.Offset(1, 0).Value) - 13)
Xsalary = Right(ActiveCell.Offset(2, 0).Value, Len(ActiveCell.Offset(2, 0).Value) - 8)
Sheets("Sheet2").Select
ActiveCell.Value = Xname
ActiveCell.Offset(0, 1).Value = Xdesig
ActiveCell.Offset(0, 2).Value = Xsalary
ActiveCell.Offset(1, 0).Select
Sheets("Sheet1").Select
ActiveCell.Offset(3, 0).Select
Else
i = 10
End If
i = i - 1
Next
Application.ScreenUpdating = True
End Sub
I think this is what you're trying to do:
Sub excelmacro()
Dim lastrowinSheet1 As Long
Dim cellinSheet2 As Range
Dim rCell As Range
Dim x As Long
With ThisWorkbook
'Set a reference to cell A1 on Sheet2.
Set cellinSheet2 = .Worksheets("Sheet2").Range("A1")
With .Worksheets("Sheet1")
'This will return the last row number containing data in column A.
lastrowinSheet1 = .Cells(Rows.Count, 1).End(xlUp).Row
'Now loop through each cell in column A of sheet1.
For x = 1 To lastrowinSheet1
If Len(.Cells(x, 1)) > 1 Then
cellinSheet2.Value = Right(.Cells(x, 1).Value, Len(.Cells(x, 1).Value) - 6)
cellinSheet2.Offset(, 1) = Right(.Cells(x, 1).Offset(1).Value, Len(.Cells(x, 1).Offset(1).Value) - 13)
cellinSheet2.Offset(, 2) = Right(.Cells(x, 1).Offset(2).Value, Len(.Cells(x, 1).Offset(2).Value) - 8)
Set cellinSheet2 = cellinSheet2.Offset(1)
x = x + 2
End If
Next x
End With
End With
End Sub
I tried taking apart your code - I think this is what it's doing:
Sub excelmacro1()
'Stop the screen flicker.
Application.ScreenUpdating = False
'Select cell A1 on Sheet1.
Sheets(“Sheet1”).Select
Range(“A1”).Select
'Select cell A2 on sheet 2.
Sheets(“Sheet2”).Select
Range(“A2”).Select
For i = 1 To 3
'Select Sheet1 again.
Sheets(“Sheet1”).Select
'If the length of text in the ActiveCell is greater than 1 character then
'execute the lines up to ELSE.
If Len(ActiveCell.Value) > 1 Then
'Select Sheet1 yet again.
Sheets(“Sheet1”).Select
'Hope the value in the ActiveCell isn't longer than 6 digits, or it will error out.
'Take all characters from the ActiveCell except the last 6.
Xname = Right(ActiveCell.Value, Len(ActiveCell.Value) - 6)
'Take all characters from the ActiveCell except the last 13.
Xdesig = Right(ActiveCell.Offset(1, 0).Value, Len(ActiveCell.Offset(1, 0).Value) - 13)
'Take all characters from the ActiveCell except the last 8.
Xsalary = Right(ActiveCell.Offset(2, 0).Value, Len(ActiveCell.Offset(2, 0).Value) - 8)
'Select Sheet2.
Sheets(“Sheet2”).Select
'Place the values in ActiveCell and the two columns to the right.
ActiveCell.Value = Xname
ActiveCell.Offset(0, 1).Value = Xdesig
ActiveCell.Offset(0, 2).Value = Xsalary
'Select the next row down.
ActiveCell.Offset(1, 0).Select
'Active Sheet1 again.
Sheets(“Sheet1”).Select
'Select the cell 3 rows down from the previous row.
ActiveCell.Offset(3, 0).Select
Else
'If the lengh of text in the ActiveCell is 1 character or less then set the value of i to 10.
i = 10
End If
'Remove 1 from i.
i = i - 1
Next
Application.ScreenUpdating = True
End Sub
I jus want to select consequent cells in a single row, until a certain cell, with the value "Total" in it. How do I do this in VBA? I'm making a VBA procedure which relies on the length of the row, which must be dynamic (the length can change).
Sub test()
Dim myRow As Long
Dim rngEnd As Range
Dim rngToFormat As Range
myRow = 4
Set rngEnd = Rows(myRow).Find("total")
If Not rngEnd Is Nothing Then
Set rngToFormat = Range(Cells(myRow, 1), rngEnd)
Debug.Print rngToFormat.Address
Else
Debug.Print "No total on row " & myRow
End If
End Sub
Inside a sub:
For i = 1 To 9999
If ActiveCell.Offset(0, i).Value = "Total" Then Exit For
If ActiveCell.Offset(0, 1).Value = "" Then Exit For
Next
If ActiveCell.Offset(0, i).Value = "Total" Then Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row, ActiveCell.Column + i - 1)).Select
The macro select from Activecell to the value of "Total".
If you want from the column 5 (sample):
For i = 1 To 9999
If ActiveCell.Offset(0, i).Value = "Total" Then Exit For
If ActiveCell.Offset(0, 1).Value = "" Then Exit For
Next
If ActiveCell.Offset(0, i).Value = "Total" Then Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, ActiveCell.Column + i - 1)).Select
Sub FindTotal()
Dim rng As Variant
rng = Rows(20) ' Then number of the row where "Total" is. Keep in mind that this will add all columns to rng and which will use a lot of memory. If you can limit the number of columns to be added e.g. rng = Range("A20:Z20") as long as Total will always be within the range
i = 1
While rng(1, i) <> "Total"
i = i + 1
Wend
End Sub