This is about VBA in excel.
I am trying to remove the sign "/" and cut the string length for every cell down to 31 to make those values valid as a name for a new sheet. The constraint is within the first two columns until the last occupied row.
My code compiled, however, it brought me endless processing and I have to task manager-exit every time after running it. Please take a look at it, thank you so much!
Sub replaceSpeCharaAndCutLength()
'selectPositionAndReplaceSpeCharaAndCutLength Macro
Dim cell As Range
Dim row As Long
For row = 7 To Sheet1.Cells(Rows.Count, 1).End(xlUp).row
Worksheets("Sheet1").Columns("A").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
Worksheets("Sheet1").Columns("B").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
For Each cell In Sheet1.Range("A:B").Cells
cell.Value = Left(cell.Value, 31)
Next cell
Next row
End Sub
Updated code 0142 08212020
Sub replaceSpeCharaAndCutLength()
'
' selectPositionAndReplaceSpeCharaAndCutLength Macro
'
Dim cell As Range
Worksheets("Sheet1").Columns("A").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
Worksheets("Sheet1").Columns("B").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
For Each cell In Sheet1.Range("A:B").Cells
cell.Value = Left(cell.Value, 31)
Next cell
End Sub
Range.Replace doesn't require a loop. You can also use Evaluate instead of the other loop:
Sub replaceSpeCharaAndCutLength()
Dim lastRow As Long
lastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Dim rng As Range
Set rng = Sheet1.Range("A7:B" & lastRow)
rng.Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
rng.Value = rng.Parent.Evaluate("INDEX(LEFT(" & rng.Address & ",31),)")
End Sub
Related
I am trying to select a range until the last used row in the sheet. I currently have the following:
Sub Select_Active_Down()
Dim lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
If Cells(ActiveCell.Row, ActiveCell.Column) = Cells(lr, ActiveCell.Column) Then
MsgBox "There isn't any data to select."
Else
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(lr, ActiveCell.Column)).Select
Cells(lr, ActiveCell.Column).Activate
End If
End Sub
The issue is that I need to select multiple columns, and this will only select the first column of the active range. How can I modify this to select multiple columns rather than just the first?
What about selection the entire region? This can be done as follows in VBA:
Selection.CurrentRegion.Select
There also is the possibility to select the entire array. For that, just press Ctrl+G, choose Special and see over there.
I would do this slightly different. I would use .Find to find the last row and the last column (using the same logic shown in the link) to construct my range rather than using Selection | Select | ActiveCell | UsedRange | ActiveSheet.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
'~~> Change it to the relevant sheet
Set ws = Sheet1
With ws
'~~> Check if there is data
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "No Data Found"
Exit Sub
End If
'~~> Find last row
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find last column
LastColumn = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Construct your range
Set rng = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
'~~> Work with the range
With rng
MsgBox .Address
'
'~~> Do what you want with the range here
'
End With
End With
End Sub
Trying to copy data from one Excel spreadsheet to another (from New_data to report).
In the New_data spreadsheet I find the second time System (hence why I start the search below the first one at N21) appears then I need to copy all data below it from columns b - k until I hit blank cells. How do I get the amount of rows to only capture filled cells?
Range("B584:K641") needs to be dynamic.
Sub CopyWorkbook()
Range("N21").Select
Cells.Find(What:="system", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range("B584:K641").Select
Selection.Copy
Application.WindowState = xlNormal
Windows("report.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("new_data.csv"). _
Activate
End Sub
Try the next code please. It should be very fast (if I correctly understood where to be searched for 'system', starting with what...). The code assumes that "new_data.csv" is the csv workbook name. If not, you must use its real name when defining shCSV sheet:
Sub CopyWorkbook()
Dim shR As Worksheet, shCSV As Worksheet, lastRow As Long, systCell As Range, arr
Set shR = Workbooks("report.xlsx").ActiveSheet 'use here the sheet you need to paste
'it should be better to use the sheet name.
'No need to have the respective sheet activated at the beginning
Set shCSV = Workbooks("new_data.csv").Sheets(1) 'csv file has a single sheet, anyhow
lastRow = shCSV.Range("B" & rows.count).End(xlUp).row
Set systCell = shCSV.Range("B21:B" & lastRow).Find(What:="system", _
After:=shCSV.Range("B21"), LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If systCell Is Nothing Then MsgBox "No 'sytem' cell has been found...": Exit Sub
arr = shCSV.Range(systCell, shCSV.Range("K" & lastRow)).Value
shR.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
Try:
Sub test()
Dim LR As Long
Dim Ini As Long
LR = Range("B" & Rows.Count).End(xlUp).Row 'last non empty row in column B
Ini = Application.WorksheetFunction.Match("system", Range("N21:N" & LR), 0) + 20 'position of system after n21
Range("B" & Ini & ":K" & LR).Copy
'''rest of your code to paste
End Sub
Note that this code is searching word system only in column N. If it's somewhere else, you'll need to adapt the MATCH function
I set a range to equal the filtered range and start a loop to count how many none empty cells occur until the first empty cell in column B.
Sub CopyWorkbook()
ThisWorkbook.Sheets("new_data").Activate
Range("N21").Select
Dim rng As Range
Set rng = Cells.Find(What:="system", After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
Dim i As Double
i = rng.Row
Do Until ThisWorkbook.Sheets("new_data").Range("B" & i) = vbNullString
i = i + 1
Loop
i = i - 1
Range("B" & rng.Row & ":K" & i).Select
Selection.Copy
Application.WindowState = xlNormal
Windows("report.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("new_data.csv").Activate
End Sub
I found a Stack Overflow question that was helpful in finding an answer. Find cell address
have to replace the word in excel cell .
using like
Sub test()
Dim a_row As String
Dim b_row As String
Dim row_counter As Integer
For row_counter = 1 To 600
a_row = "A" & row_counter
b_row = "B" & row_counter
Dim Findtext As String
Dim Replacetext As String
Findtext = Sheets("sheet1").Range(a_row).Value
Replacetext = Sheets("sheet1").Range(b_row).Value
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ActiveWorkbook.Worksheets(1).Name Then
ws.Cells.Replace What:=Findtext, Replacement:=Replacetext, LookAt:= _
xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End If
Next ws
Next row_counter
End Sub
there are two cols in sheet1. 1st cols shows Japanese words. 2nd column shows English words.
公園 park
夏 summer
緑 Green
青空 blue Sky
男の人 man
In the 2nd sheet displays in col A
column A
公園、夏、青空、緑、男の人
the above code replace Japanese words.
if LookAt:= _xlPart, after replace shows like below
park, summer, 青sky, green,manの人
if LookAt:= _xlWhole , its not replacing the word
In the 2nd sheet displays in the separate columns
A B C D E
公園 夏 青空 緑 男の人
if LookAt:= _xlWhole then
its working perfectly.
i want to do
In the 2nd sheet displays the value in single col A delimited by comma
column A
公園、夏、青空、緑、男の人
need the output like
park, summer, blue sky, green,man
please give some idea.. thanks
Do it in memory instead, it's quicker and much easier to work with arrays. If I understand the way your data is set out - the following should work where your find/replace table is in columns A:B on sheet1 and the values to replace are in sheet2 and are comma separated in cell A1:
Sub MM_Foo()
Dim findArray As Variant
Dim replaceArray As Variant
Dim matchPosition As Long
With Sheets(1)
findArray = .Range("A1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).Value
End With
On Error GoTo checkErr:
For j = 1 To Sheets(2).Cells(Sheets(2).Rows.Count, 1).End(xlUp).Row
replaceArray = Split(Sheets(2).Cells(j, 1).Value, ",")
With Application
For i = LBound(replaceArray) To UBound(replaceArray)
matchPosition = .Match(replaceArray(i), .Index(findArray, , 1), 0)
replaceArray(i) = findArray(matchPosition, 2)
skipReplace:
Next
End With
Sheets(2).Cells(j, 1).Value = Join$(replaceArray, ",")
Next
On Error GoTo 0
Exit Sub
checkErr:
If Err.Number = 13 Then
Err.Clear
GoTo skipReplace:
Else
MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation, "Error"
Err.Clear
On Error GoTo 0
Exit Sub
End If
End Sub
Without a trailing 'comma', there may have to be repetitive passes that may or may not actually do anything; there need to cover all possible combinations.
Sub delimitedTranslate()
Dim w As Long, vWRDs As Variant
With Worksheets("Sheet1")
vWRDs = .Range(.Cells(2, "A"), _
.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1)) _
.Value2
End With
With Worksheets("Sheet2")
With .Columns("A")
For w = LBound(vWRDs, 1) To UBound(vWRDs, 1)
.Replace what:=vWRDs(w, 1) & ChrW(12289), _
replacement:=vWRDs(w, 2) & Chr(44), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
.Replace what:=ChrW(12289) & vWRDs(w, 1), _
replacement:=Chr(44) & vWRDs(w, 2), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
.Replace what:=Chr(44) & vWRDs(w, 1), _
replacement:=Chr(44) & vWRDs(w, 2), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
Next w
End With
End With
End Sub
Sheet1 terms Sheet2 before delimitedTranslate Sheet2 after delimitedTranslate
I have a bit of code that finds blanks in a given column and replaces them with "BLANK", this has worked fine in the past and works for all of the sheets I am looking at bar one.
In the 'meter' sheet the whole column is blank, yet the find and replace fills all bar 6 of the blanks with no apparent pattern as below. I expect this could be another of my Monday morning 'user malfunction' errors but would appreciate any insight.
I am aware this would be better in a loop, which I will write once I've fixed the problem of it missing some blanks.
Cheers
Public Function FILL_blanks() '''' this searches for blanks
'in the columns in the raw data we are interested in and replaces
'them with BLANK there is a value assigned to BLANK in the flag matrix.
Dim LastRow_g As Long '''' HYDRANT, NODE ---->CHANGES LENGTH FOR EACH ASSET
Dim LastRow_j As Long ''''
Dim LastRow_bp As Long ''''
Dim WS_Count As Integer
Dim i As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For i = 1 To WS_Count
If ActiveWorkbook.Worksheets(i).Name = "hydrant" Then
Worksheets(i).Select
Range("g4").Select ' this will change j/g/bp only
LastRow_g = Range("g" & Rows.Count).End(xlUp).Row 'define the last row as all of the rows in DMA flag column
Range("r4:r" & LastRow_g).Select
'find and replace below
Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ElseIf ActiveWorkbook.Worksheets(i).Name = "meter" Then
Worksheets(i).Select
Range("j4").Select
LastRow_j = Range("j" & Rows.Count).End(xlUp).Row 'define the last row
Range("y4:y" & LastRow_j).Select
'find and replace below
Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
I would use Sub here rather than Function because there doesn't seem to be a return. This code replaces blank cells in the columns specified above:
Option Explicit
Sub FillBlanks2() '''' this searches for blanks
Dim LastRow As Long '''' HYDRANT, NODE ---->CHANGES LENGTH FOR EACH ASSET
Dim Sheet As Worksheet
Dim TargetRange As Range
'loop through worksheets in this workbook
For Each Sheet In ThisWorkbook.Worksheets
If Sheet.Name = "hydrant" Then '<~ concerned with col G on hydrant sheet
With Sheet
LastRow = .Range("G" & .Rows.Count).End(xlUp).Row
Set TargetRange = .Range(.Cells(4, 7), .Cells(LastRow, 7))
End With
'apply replacement to the target range
TargetRange.Replace What:="", Replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
ElseIf Sheet.Name = "meter" Then '<~ concerned with col J on hydrant sheet
With Sheet
LastRow = .Range("J" & .Rows.Count).End(xlUp).Row
Set TargetRange = .Range(.Cells(4, 10), .Cells(LastRow, 10))
End With
'apply replacement to the target range
TargetRange.Replace What:="", Replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
End If
Next Sheet
End Sub
I adapted the code from Dan Wagner to account for cells that appear blank but actually have spaces in them. if the cells are only likely to contain a blank or one space then it is possible to use "" and " ".
However, I am sure there is a more elegant solution that accounts for all blank spaces. SpecialCells(xlCellTypeBlanks) is a possibility but it appears to be limited to a certain number of rows.
Sub FILL_blanks() '''' this searches for blanks
Dim LastRow As Long '''' HYDRANT, NODE ---->CHANGES LENGTH FOR EACH ASSET
Dim Sheet As Worksheet
Dim TargetRange As Range
Sheets("Sheet1").Select
LastRow = Range("a" & Rows.Count).End(xlUp).Row
Set TargetRange = Range("b4:b" & LastRow)
'apply replacement to the target range
'"" accounts for true blank cells (no spaces)
' "*" is a wildcard and accounts for one or more spaces
TargetRange.Replace What:="", replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
TargetRange.Replace What:=" ", replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
End Sub
Thanks again for your assistance
So I currently a macro that assigns a cell value to a variable and then search for this variable on a another sheet. The problem is that I am having to do this a large number values so I currently have the same code copied 20 times allowing for 20 values to be search in series. Is there a cleaner method of running a repeatable operation like this? Also is it possible to set the upper limit based on the number of values entered. E.g. my current setup looks cells M8:M27 for it's variables, is it possible however to write it so that it is repeated continuously until it hits a blank cell? Thereby letting the user enter as many values as required?
Here is an extract for a single variable. This is then repeated up to reverse_id_20
Sheets("GR Input").Select
reverse_id_1 = Range("O8")
Sheets("PchOrds").Select
Columns("A:A").Select
Selection.Find(What:=reverse_id_1, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Select
Rows(ActiveCell.Row).Select
Selection.Delete Shift:=xlUp
Sheets("GR Input").Select
Thanks in advance guys,
Dan
Is there a cleaner method of running a repeatable operation like this?
Yes, it is. You can use loop for it:
Sub test()
Dim reverse_id As Variant
Dim rng As Range
Dim r_id As Variant
With Sheets("GR Input")
reverse_id = .Range("O8:O11")
End With
For Each r_id In reverse_id
Set rng = Sheets("PchOrds").Columns("A:A").Find( _
What:=r_id, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False)
If Not rng Is Nothing Then
rng.EntireRow.Delete Shift:=xlUp
End If
Next r_id
End Sub
Btw, code above deletes only first row that meet criteria. If you'd like to delete all values from sheet "PchOrds", that meet criteria, use this code:
Sub test1()
Dim reverse_id As Variant
Dim rng As Range
Dim lastrow As Long
Dim r_id As Variant
With Sheets("GR Input")
reverse_id = .Range("O8:O11")
End With
For Each r_id In reverse_id
If r_id <> "" Then
With Sheets("PchOrds")
lastrow = Application.Max(2, .Cells(.Rows.Count, "A").End(xlUp).Row)
.AutoFilterMode = False
With .Range("A1:A" & lastrow)
.AutoFilter Field:=1, Criteria1:="=*" & r_id & "*"
.Offset(1, 0).Resize(lastrow - 1, 1).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End If
Next r_id
End Sub