I've got the following code that works very slowly. Any ideas on how to make faster?
Some background, in a previous Sub I had taken a range and then copy and pasted it. Now I need to change the values according to the code. Would it be possible to take this range and subject it to the modifications without pasting it first maybe?
Sub ChangeArea()
Dim Book As Workbook
Dim Sheet As Worksheet
Dim AreaRange As Range
Dim LastRow
Dim c As Range
Set Book = Workbooks("Testing")
Set Sheet = Book.Worksheets("Data")
Sheet.Activate
LastRow = Sheet.Cells(Rows.Count, "AG").End(xlUp).Row
Set AreaRange = Sheet.Range("AG5:AG" & LastRow)
For Each c In AreaRange.Cells
If c.Value = "10" Then
c.Value = "Mark"
ElseIf c.Value = "will" Then
c.Value = "William"
ElseIf c.Value = "Uncle" Then
c.Value = "Bill"
ElseIf c.Value = "Roomate" Then
c.Value = "Robert"
Else: End If
Next
End Sub
An option may be to use the Replace method on your range. See below and try to accommodate into your worksheet.
Sub ChangeThem()
Dim rng As Range
Dim lRow As Long
lRow = Sheet1.Cells(Rows.Count, "AG").End(xlUp).Row
Set rng = Sheet1.Range("AG5:AG" & lRow)
rng.Replace what:=1, replacement:="One"
rng.Replace what:=2, replacement:="Two"
rng.Replace what:=3, replacement:="Three"
End Sub
Try adding
Application.ScreenUpdating = false
to the top and
Application.ScreenUpdating = True
to the bottom
This keeps the screen from updating on every change.
Related
I'd like the code to paste 'cashb' underneath 'rngcel', but every time
I run the code 'cashb''s value appears above 'rngCel'.value. Rngcell's range is from A2:A34, I'd like 'Cashb' to appear right below it at A35. I tried putting 'A35' in the
range but it does not work.
This is the code that I want to appear below rngcel.value.
Sheets(" Price").Range("A35").Resize(Cashb.Rows.Count).Value = Cashb.Value
I'd also like to return the column that's 5 columns to the right of "cashb"range
I appreciate any help that I receive.
This is the code that I have.Thanks in advance.
Sub liveP()
Application.ScreenUpdating = False
Dim rngTicker As Range
Dim rngCel As Range
Dim Cashb As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Live"
Set rngTicker = Worksheets("prices").Range("H16:H200")
Set Cashb = Sheets("prices").Range("cashbalances")
For Each rngCel In rngTicker
If rngCel.Font.ColorIndex = 33 Then
Worksheets("Live").Cells(Rows.Count, 1).End(xlUp).offset(1).Resize(1, 2).Value = Array(rngCel.offset(, "-7").Value, rngCel.Value) ' this is range cell value'
WorkSheets("Live").Range("A35").Resize(Cashb.Rows.Count).Value = Cashb.Value.offset ' this is the value I'd like to appear under rngcel value
'New data that im posting on the Live sheet'
Sheets("Live").Range("C2:H33").Formula = "=($B2 +$C5)"
Sheets("Live").Range("A1") = "Header1"
Sheets("Live").Range("B1") = "Header2"
Sheets("Live").Range("C1") = "Header3"
Sheets("Live").Range("D1") = "Header4"
Sheets("Live").Range("E1") = "Header5"
Sheets("Live").Range("F1") = "Header6"
End If
Next
Application.ScreenUpdating = True
End Sub
Try This
Sub liveP()
Application.ScreenUpdating = False
Dim rngTicker As Range
Dim rngCel As Variant 'used in for each this should be variant
Dim Cashb As Range
Dim ws As Worksheet
Dim LastRow As Long 'dimensioned variable for the last row
Dim CashbRows As Long 'dimensioned variable for Cashb rows
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Live"
Set rngTicker = Worksheets("prices").Range("H16:H200")
Set Cashb = Sheets("prices").Range("cashbalances")
'Assuming "cashbalances" is a named range in the worksheet
CashbRows = Cashb.Rows.Count
For Each rngCel In rngTicker
If rngCel.Font.ColorIndex = 33 Then
With Worksheets("Live")
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'set lastrow variable
.Cells(LastRow, 1) = rngCel.Offset(0, -7).Value 'putting value 7 columns before into live worksheet column A
.Cells(LastRow, 2) = rngCel.Value 'putting value into live worksheet column B
.Range(.Cells(35, 1), .Cells(35 + CashbRows, 1)) = Cashb.Offset(, 5).Value 'im not really sure if this line is going to work at all
'New data that im posting on the Live sheet'
.Range("C2:H33").Formula = "=($B2 +$C5)"
.Range("A1") = "Header1"
.Range("B1") = "Header2"
.Range("C1") = "Header3"
.Range("D1") = "Header4"
.Range("E1") = "Header5"
.Range("F1") = "Header6"
End With
End If
Next
Application.ScreenUpdating = True
End Sub
Modifications:
rngCel is now a variant not a range
Using a LastRow Variable to get away from offset
Removed the array when placing data into "LIVE" because why not
CashbRows will now only be calculated one time before the loop. Saving time
The With Worksheets("Live") statement is a time saving measure.
You were calling A35 as a range, which it is not, then resizing to a range maybe? Hard to know when I cant tell what "cashbalances" is. If "cashbalances is only 1 row or may ever be 1 row, then you will need to add an If Then Else control to handle it.
Also A35 gets overwritten every single loop... so not sure what you want to do there.
I hope I was able to understand your questions well enough to get you going in the right direction.
EDIT
Stop treating "cashbalances" as a named range. I believe VBA is hanging onto the original row numbers of the range, similar to how Variant arrays start at 1 when assigned as I do in the following. It does not look like you are modifying "cashbalances" so create a variant array before the loop but after CashbRows.
EXAMPLE:
Dim CB() as variant, j as long
with sheets("PUT THE SHEET NAME OR INDEX HERE")
CB = .range(.cells(1,6), .cells(CashbRows,6)).value 'address to whatever .offset(,5) is
'i assumed cashb was in column A
Instead of .Range(.Cells(35, 1), .Cells(35 + CashbRows, 1)) = Cashb.Offset(, 5).Value Use:
For j = 1 to CashbRows
.cells(34 + j, 1) = CB(j)
Next j
I have written a macro to remove rows containing certain text in it. If either of the keyword contains any text, the macro will delete the row. However, the macro doesn't work at all. Perhaps, i did something wrong in it. Hope somebody will help me rectify this. Thanks in advance.
Here is what I'm trying with:
Sub customized_row_removal()
Dim i As Long
i = 2
Do Until Cells(i, 1).Value = ""
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Cells(i, 1).Select
Selection.EntireRow.Delete
End If
i = i + 1
Loop
End Sub
The keyword within the text I was searching in to delete:
AIRLINE DRIVE OWNER mth
A rtd REPAIRS INC
AANA MICHAEL B ET AL
ABASS OLADOKUN
ABBOTT npt P
AIRLINE AANA MTH
ABASS REPAIRS NPT
Try like this.
What about Using Lcase.
Sub customized_row_removal()
Dim rngDB As Range, rngU As Range, rng As Range
Dim Ws As Worksheet
Set Ws = Sheets(1)
With Ws
Set rngDB = .Range("a2", .Range("a" & Rows.Count))
End With
For Each rng In rngDB
If InStr(LCase(rng), "mth") Or InStr(LCase(rng), "rtd") Or InStr(LCase(rng), "npt") Then
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End If
Next rng
If rngU Is Nothing Then
Else
rngU.EntireRow.Delete
End If
End Sub
VBA syntax of your Or is wrong,
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Should be:
If Cells(i, 1).Value = "mth" Or Cells(i, 1).Value = "rtd" Or Cells(i, 1).Value = "npt" Then
However, you need to use a string function, like Instr or Like to see if a certain string is found within a longer string.
Code
Option Explicit
Sub customized_row_removal()
Dim WordsArr As Variant
Dim WordsEl As Variant
Dim i As Long, LastRow As Long
Dim Sht As Worksheet
WordsArr = Array("mth", "rtd", "npt")
Set Sht = Worksheets("Sheet1")
With Sht
' get last row in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LastRow To 2 Step -1
For Each WordsEl In WordsArr
If LCase(.Cells(i, 1).Value) Like "*" & WordsEl & "*" Then
.Rows(i).Delete
End If
Next WordsEl
Next i
End With
End Sub
I try to make my code sample as I can if you have any question please ask
Private Sub remove_word_raw()
'PURPOSE: Clear out all cells that contain a specific word/phrase
Dim Rng As Range
Dim cell As Range
Dim ContainWord As String
'What range do you want to search?
Set Rng = Range("A2:A25")
'sub for the word
shorttext1 = "mth"
shorttext2 = "rtd"
shorttext3 = "npt"
'What phrase do you want to test for?
ContainWord1 = shorttext1
ContainWord2 = shorttext2
ContainWord3 = shorttext3
'Loop through each cell in range and test cell contents
For Each cell In Rng.Cells
If cell.Value2 = ContainWord1 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord2 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord3 Then cell.EntireRow.Delete
Next cell
End Sub
I know this has been asked lot of times but I'm having a trouble with VBA, I am very new to VBA.
I'm working with a single workbook that has a working worksheet. basically I need to sort the Currency column, currently have 14 currencies, I need loop through it (since currency may add through time depending on the customer) then copy the row with the criteria paste it to another sheet with its cell value.
my code below.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In rng
If CStr(xCell.Value) = "USD" Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = xCell.Value
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
'Sheets.Add After:=Sheets(Sheets.Count)
'Sheets(Sheets.Count).Name = xCell.Value
Application.CutCopyMode = False
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I basically got the codes from my research, add them up and not coming into the way I wanted. I wanted to keep the header and the values with criteria,
i,e currency column "AB" is USD as per example above, but the problem is it'll be a lot of coding because I have to go through all 14 currencies plus if there will be new currency that will be added,
also I know there is a way of not declaring multiple sheets and just having another new worksheet with the cell value name but I'm having a problem getting it done all at once. if there will be a simpler and powerful code. I am greatly thankful.
you may want to try this code, exploiting Autofilter() method of Range object
Option Explicit
Sub SortCurrency()
Dim currRng As Range, dataRng As Range, currCell As Range
With Worksheets("Currencies") '<--| change "Currencies" to your actual worksheet name to filter data in and paste from
Set currRng = .Range("AB1", .Cells(.Rows.Count, "AB").End(xlUp))
Set dataRng = Intersect(.UsedRange, currRng.EntireRow)
With .UsedRange
With .Resize(1, 1).Offset(, .Columns.Count)
With .Resize(currRng.Rows.Count)
.Value = currRng.Value
.RemoveDuplicates Array(1), Header:=xlYes
For Each currCell In .SpecialCells(xlCellTypeConstants)
currRng.AutoFilter field:=1, Criteria1:=currCell.Value
If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
End If
Next currCell
.ClearContents
End With
End With
End With
.AutoFilterMode = False
End With
End Sub
Function GetOrCreateWorksheet(shtName As String) As Worksheet
On Error Resume Next
Set GetOrCreateWorksheet = Worksheets(shtName)
If GetOrCreateWorksheet Is Nothing Then
Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
GetOrCreateWorksheet.name = shtName
End If
End Function
You're pretty close with what you've got, but there's a few things to note:
On Error Resume Next is normally a bad plan as it can hide a whole lot of sins. I use it in the code below, but only because I immediately deal with any error that might have happened.
xCell.Value.Range("A" & J + 1) makes no sense. Chop out the middle of that line to leave xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
Rather than checking if the value is a specific currency, you should be taking the value, whatever currency it is, and dealing with it appropriately.
Using J as a counter works for one currency, but when dealing with multiple, it'll be easier to just check where it should go on the fly.
All told, the below code should be close to what you're looking for.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim targetSheet As Worksheet
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
Application.ScreenUpdating = False
For Each xCell In rng
Set targetSheet = Nothing
On Error Resume Next
Set targetSheet = Sheets(xCell.Value)
On Error GoTo 0
If targetSheet Is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count)
Set targetSheet = Sheets(Sheets.Count)
targetSheet.Name = xCell.Value
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & J + 1)
Else
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & targetSheet.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub
OK, there's quite a lot going on here... I'm going to try and tackle one problem at a time.
1 - You could do with testing whether a worksheet already exists rather than creating it every time
Assuming you want to do something for each and every currency in your loop, I would suggest not using the if condition you're using at the moment, "if value = "USD"", and instead use the cell value to determine the name of the sheet, whatever the cell value is.
First of all you need a seperate function to test whether the sheet exists, like
Public Function DoesSheetExist(SheetName as String)
On Error Resume Next
Dim WkSheet as WorkSheet
'sets worksheet to be the sheet NAMED the current currency name
Set WkSheet = Sheets(SheetName)
'because of on error resume next, WkSheet will simply be "Nothing" if no such sheet exists
If WkSheet is Nothing Then
DoesSheetExist = False
Else
DoesSheetExist = True
End If
End Function
You can then call this function in your code, and only create new sheets when you need to
2 - The loop itself
So instead, I would suggest your loop probably wants to look more like this:
Dim xSheet as Worksheet 'declare this outside the loop
For Each xCell In rng
If DoesSheetExist(xCell.Value) Then
set xSheet = Sheets(xCell.Value) 'this is the code for if the sheet does exist - sets the sheet by the sheet name rather than index
Else
set xSheet = Sheets.Add After:=Sheets(Sheets.Count)
xSheet.Name = xCell.Value
End if
With this setup, for every currency your loop will either set xSheet to the currency sheet that already exists, or create that sheet. This assumes that you want to do the same thing to all currencies, if not then extra conditions will need adding in
3 - the copy/paste line itself
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
I don't think this code says what you think it does - what this code actually says is "Copy the Entire Row to the last Sheet's name, and make it equal to the range within xCell's Value at A, (J)+1
I think what you actually wanted to say was this:
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
However, if you're using the code I gave you above you can instead use this now:
xCell.EntireRow.Copy Destination:=xSheet.Range("A" & J + 1)
In fact, you'd be better off doing that, especially if there is a chance that the sheets already existed and were picked up by DoesSheetExist
Personally I would also rather transfer values over than use copy/paste any day, but that's just an efficiency thing, the above should function fine.
I've been working with some code that opens a workbook and finds values based off a reference cell. It searches for a string and takes the cell next to it. unfortunately i now have 2 cells in the workbook that 'contain' the reference string. one cells is "Current Score" the other is "Percentage of Current Score". Is there a way to state that I just want "Current Score" and nothing else in the cell.
Sorry if this is a tad wordy, I can provide the code if necessary
EDIT: Here is the code:
Sub Future_Score()
Dim r
Dim findValues() As String
Dim Wrbk As Workbook
Dim This As Workbook
Dim sht As Worksheet
Dim i
Dim tmp
Dim counter
Dim c As Range
Dim firstAddress
Dim rng As Range
ReDim findValues(1 To 3)
findValues(1) = "Curren" & "*" & "Core"
findValues(2) = "dummyvariable1"
findValues(3) = "dummyvariable2"
counter = 0
r = Range("A163").End(xlDown).Row
Set rng = Range(Cells(163, 1), Cells(r, 1))
Set This = ThisWorkbook
For Each tmp In rng
Workbooks.Open tmp
Set Wrbk = ActiveWorkbook
'For Each sht In Wrbk.Worksheets
Set sht = ActiveSheet
For i = 1 To 3
With sht.Range(Cells(1, 1), Range("A1").SpecialCells(xlCellTypeLastCell))
Set c = .Find(findValues(i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Offset(0, 1).Value
secondAddress = c.Offset(0, 3).Value
thirdAddress = c.Offset(0, 4).Value
Do
This.Activate
tmp.Offset(0, 4).Value = firstAddress
Set c = .FindNext(c)
counter = counter + 1
Loop While Not c Is Nothing And c.Value = firstAddress
End If
End With
Wrbk.Activate
Next
'Wrbk.Activate
'Next sht
Wrbk.Close
Next tmp
End Sub
Have played around with the code a bit. The dummy variables will be in use for other functions, but basically the gist is to open a workbook, find a cell, take the cell next to it, paste in the original workbook. The problem is it picks up multiple cells that contain a string. I have used "Curren" & "Core" as the macro doesn't seem to handle spaces in strings to well.
Change
Set c = .Find(findValues(i), LookIn:=xlValues)
to
Set c = .Find(findValues(i), LookIn:=xlValues, LookAt:=xlWhole)
to require that the entire cell match the search string, rather than just part of the cell.
Created a macro below thanks to help from another that works.
Basically, it takes the value of the cell in column A and, if a sheet doesn't exist with that cells name, creates it. Then it pastes all rows of data that have the corresponding cell value to that sheet. Ie. if a cell contains the following:
column a column b
dc00025 data value
If dc00025 doesn't exist, it'll make the sheet. And paste all rows with dc00025 in A.
This works perfectly. However, I noticed when you run this macro after a sheet has already been created, for some reason it adds thousands of columns dramatically slowing down excel.
To fix this, would it be possible to modify the script to only copy columns b:o rather tahnt he entire row? Pasting them starting at A3 would be preferable but I'm not sure how to fix that.
Thanks in advance.
Sub CopyCodes()
Application.ScreenUpdating = False
Dim rCell As Range
Dim lastrow As Long
lastrow = Sheets("Data").UsedRange.Rows.Count
For Each rCell In Worksheets("Data").Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)
If Not SheetExists(rCell.Value) Then
With Worksheets.Add(, Worksheets(Worksheets.Count))
.Name = rCell.Value
End With
End If
Worksheets("Data").Rows(1).EntireRow.Copy Worksheets(rCell.Value).Rows(1)
Worksheets(rCell.Value).Range("A" & Rows.Count).End(xlUp)(2).EntireRow.Value = _
rCell.EntireRow.Value
Next rCell
Application.ScreenUpdating = True
End Sub
Function SheetExists(wsName As String)
On Error Resume Next
SheetExists = Worksheets(wsName).Name = wsName
End Function
Suggested fix:
Sub CopyCodes()
Application.ScreenUpdating = False
Dim rCell As Range
Dim lastrow As Long
Dim shtData as worksheet, shtDest as worksheet
Dim sheetName as string
set shtData=worksheets("Data")
lastrow = shtData.cells(rows.count,1).end(xlup).row
For Each rCell In shtData.Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)
sheetName = rCell.Value
If Not SheetExists(sheetName) Then
set shtDest = Worksheets.Add(, Worksheets(Worksheets.Count))
shtDest.Name = sheetName
shtData.Rows(1).EntireRow.Copy shtDest.Rows(1)
Else
set shtDest = Worksheets(sheetName)
End If
shtDest.Range("A" & Rows.Count).End(xlUp).offset(1,0).EntireRow.Value = _
rCell.EntireRow.Value
Next rCell
Application.ScreenUpdating = True
End Sub