I would like to, if possible, create a VBA macro to search the entire column A for any words that contain the letters RU (case sensitive, if possible). I would then like for it to be able to copy those words and paste them on a new sheet starting on A1, then A2, etc. I know how to set the range, but I don't even know how to begin to write the rest. Any help will be greatly appreciated.
Best Regards.
Consider:
Sub RUthere()
Dim RU As String, N As Long, K As Long, _
s1 As Worksheet, s2 As Worksheet, r As Range, _
v As Variant
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
RU = "RU"
K = 1
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
Set r = s1.Cells(i, "A")
v = r.Value
If InStr(1, v, RU) > 0 Then
r.Copy s2.Cells(K, "A")
K = K + 1
End If
Next i
End Sub
Related
All-
I'm very new to VBA and I really need help. I have a worksheet called Sheet 1 that looks like this (This is where the data will be copied from)
and another sheet (Sheet2) that looks like this (this is where the data will be copied to). Notice that the order is not the same as above
When a user types in a place such as "Paris" I want it to copy all corresponding values with "Paris" and it's associated rows. So the end result should look like this
Here is the code I have so far. Right now I can pull all the corresponding values based on the Users input, but I cannot for the life of me figure out how to get the associated rows. Please help! Any input will be highly appreciated.
Dim x As String
Dim K As Long
Dim ct As Variant
Dim r As Range
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
x = Application.InputBox("Please Enter Place")
w1.Activate
K = 3
For Each r In Intersect(Range("C3:C3" & a), ActiveSheet.UsedRange)
ct = r.Value
If InStr(ct, x) > 0 And ct <> "" Then
r.Copy w2.Cells(K, 1)
K = K + 1
w2.Activate
End If
Next r
End Sub
Assign the entire range to an array for quicker looping, then once the array finds a match to your inputstring, rewrite the values to your 2nd sheet.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, wsArr()
set ws1 = thisworkbook.worksheets("Sheet1")
set ws2 = thisworkbook.worksheets("Sheet2")
With ws1
wsArr = .Range(.Cells(3, 1), .Cells(LastRow(ws1), 4)).Value
End With
Dim findStr As String
findStr = InputBox("Please Enter Place")
Dim i As Long, r as long
Application.ScreenUpdating = False
With ws2
.Range("A3:D3").Value = array("Place", "Name", "Thing", "Animal")
For i = LBound(wsArr) To UBound(wsArr)
If wsArr(i, 3) = findStr Then
r = LastRow(ws2) + 1
.Cells(r, 1) = wsArr(i, 3)
.Cells(r, 2) = wsArr(i, 1)
.Cells(r, 3) = wsArr(i, 2)
.Cells(r, 4) = wsArr(i, 4)
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
With ws
LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
End Function
For even better performance, consider doing a COUNTIF() to get the count of the number of findStr occurances in your range - that way you can use this value to ReDim a new array in order to write the matches there, then write the array to Sheet2 all at once.
I am having trouble trying to include something into a macro I am building. I need it to search through column C
for cells that say "start trans" and in one column over (d)- the first value will be equal to zero, next instance should be 100, next instance 0 next instance 100 so on until the end of the data.
Instances are not always every 4th line and I have other zeros that I want it to overlook.
Thank you for any help!
How about this one:
Sub GoGoGo()
Dim l As Long: Dim i As Long
Dim b As Boolean
With ActiveSheet
l = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 5 To l
If .Cells(i, "C").Value2 = "start trans" Then .Cells(i, "D").Value2 = b * -100: b = Not b
Next i
End With
End Sub
Try this.
Sub test()
Dim rngDB As Range, rng As Range
Dim n As Long, Result As Integer
Set rngDB = Range("c5", Range("c" & Rows.Count).End(xlUp))
For Each rng In rngDB
If rng = "start trans" Then
n = n + 1
If n Mod 2 Then
Result = 0
Else
Result = 100
End If
rng.Offset(0, 1) = Result
End If
Next rng
End Sub
I am trying to apply the =LOWERCASE() formula to four columns (J, O, T, and Y) across multiple sheets in the same workbook.
Here's the VBA code I have so far, it is applying to the right columns, but it's returning an error for each.
Sub Clean_Lowercase()
Const N As Integer = 1
Dim r As Long, i As Integer, X As Integer, t As Long
Dim rng As Range, r As Range
Dim v As Variant
v = Array("J", "O", "T", "Y")
t = 1
For i = 1 To Sheets.Count - 1
r = Sheets(i).UsedRange.Rows.Count
For X = 0 To UBound(v)
Set rng = Sheets(i).Range(v(X) & N & ":" & v(X) & r)
For Each r In rng
r.Formula = "=LOWERCASE()"
Next
Next
End Sub
I am very new to VBA coding, any suggestions is greatly appreciated! I really want to learn.
Many thanks!
There are several problems with this.
You are using the r twice, once as a Long, once az a Range.
The For Each loop's Next is missing
The formula needs a reference of what would you like to set to lowercase.
For example, if you want to have the lowercase value of the left neightbouring cells, you should write: =LOWERCASE(R[1]C[-1])
Sheets are a 1 based collection, so if you write For i = 1 To Sheets.Count - 1, the last sheet wont be processed (maybe this is intentional?) and the code will throw an error at the first sheet (no sheets(0) exist)
Something like this works:
Sub Clean_Lowercase()
Const N As Integer = 1
Dim r As Long, i As Integer, X As Integer, t As Long
Dim rng As Range, ri As Range
Dim v As Variant
v = Array("J", "O", "T", "Y")
t = 1
For i = 1 To Sheets.Count
r = Sheets(i).UsedRange.Rows.Count
For X = 0 To UBound(v)
Set rng = Sheets(i).Range(v(X) & N & ":" & v(X) & r)
For Each ri In rng
ri.Formula = "=LOWERCASE(R[1]C[-1])"
Next
Next
Next
End Sub
If I have a long list of text in Column A, and a short list of words in Column C, what would be the best way to go about searching each cell in A for any of the words in C, and copy and paste the ones that match out into Column B?
The code I have written so far is as follow
Sub ListKeywordQualifier()
Dim Rng As Range
Dim Keyword As Range
Dim Chunk As Range
Dim x As Long
x = 1
While x <= 5000
Set Rng = Range("A" & x)
Set Chunk = Range("C1", "C100")
Application.ScreenUpdating = True
Range("D1").Value = x
If Application.WorksheetFunction.CountIf(Chunk, Rng) = 0 Then
x = x + 1
ElseIf Application.WorksheetFunction.CountIf(Chunk, Rng) = 1 Then
Rng.Copy
Rng.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
x = x + 1
End If
Wend
End Sub
However, this will onl;y give me exact matches between the two. Is it possible to do the same, but have text that appears in Column C, while only making up part of Column A, trigger the copy/paste line?
Thanks
your countif is not working because it is a worksheet function, to implement countif.... you need to write it like
WorksheetFunction.CountIf . Still your code is not looking Good , Try This!
Sub ListKeywordQualifier()
Dim Rng(50) As String
Dim Chunk(50) As String
Dim i As Long
i = 1
'' Take a value From 3rd Column this works for 10 cells ,
For i = 1 To 10
Chunk(i) = Cells(i, 3)
''Search it in 1st Column in 10 cells
For j = 1 To 10
Rng(j) = Cells(j, 1)
''If it matches
If Chunk(i) = Rng(j) Then
''Then copy that value to Second Column
Cells(i, 2).Value = Rng(j)
End If
Next j
Next i
End Sub
This is just to give you an idea , you still need make changes Thanks
Consider:
Sub ListKeywordQualifier()
Dim A As Range, C As Range, aa As Range, cc As Range
Dim K As Long, va, vc, boo As Boolean
Set A = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set C = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
K = 1
For Each aa In A
va = aa.Value
boo = False
For Each cc In C
If InStr(1, va, cc.Value) > o Then boo = True
Next cc
If boo Then
aa.Copy Cells(K, "B")
K = K + 1
End If
Next aa
End Sub
Before:
and after:
Posting this from the Stack Exchange app so forgive me if the formatting is a bit off.
Basically, I want to do something really simple. I have a spreadsheet with some data. Headers are on the first row. I want to loop through the columns and delete those where all the rows in that column have a value of zero. If any of the values are nonzero, the column must stay.
Can anyone suggest a succinct, easy to read way of doing this. I want to try to avoid looping, looking for something compact and elegant.
Thank you
This is not too "un-elegant"
Sub ColumnKiller()
Dim N As Long, i As Long
N = Cells(1, Columns.Count).End(xlToLeft).Column
For i = N To 1 Step -1
If Application.WorksheetFunction.Sum(Range(Cells(2, i), Cells(Rows.Count, i))) = 0 Then
Cells(2, i).EntireColumn.Delete
End If
Next i
End Sub
EDIT#1
The code above will work if there are not negative values below the first row. If the lower rows can contain negative values, then the following code should be used:
Sub ColumnKiller2()
Dim N As Long, i As Long, wf As WorksheetFunction, Kount As Long
Dim s1 As String, s2 As String
s1 = "=0"
s2 = "="
Set wf = Application.WorksheetFunction
N = Cells(1, Columns.Count).End(xlToLeft).Column
For i = N To 1 Step -1
Set r = Range(Cells(2, i), Cells(Rows.Count, i))
Kount = wf.CountIf(r, s1) + wf.CountIf(r, s2)
If Kount = Rows.Count - 1 Then
Cells(2, i).EntireColumn.Delete
End If
Next i
End Sub
Each column is examined and if all the cells below the first row contain either zeros or blanks, that column is deleted.