I'm trying to create a VBA Macro that would search for a non-blank cell in "Sheet1" and if non-blank, it would paste the respective active cell column from "Sheet1" to the same column in "Sheet2".
Below is my code, but I'm sure I'm doing something wrong, because the code is throwing me an error : 1004.
Sub Test()
Dim cel As Range
Dim strAddress As String
Dim StartPoint As Range
Set StartPoint = ActiveCell
'Change to necessary amount of Rows & Columns
With Sheets("Sheet1").Range(Cells(9, 5), Cells(1000, 200))
Set cel = .Find(What:="*", After:=Cells(1000, 200), SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not cel Is Nothing Then
strAddress = cel.Address
Do
' Do something with cel, e.g.
StartPoint.EntireColumn.Copy Destination:=Worksheets("Sheet2").Range(StartPoint.Column & "1").End(xlToRight).Offset(1)
Set cel = .FindNext(After:=cel)
If cel Is Nothing Then Exit Do
Loop Until cel.Address = strAddress
End If
End With
End Sub
Can someone kindly advise what I'm doing wrong?
Thank you!
Try these two modifications:
With Sheets("Sheet1").Range("E9:GR1000")
.
cel.EntireColumn.Copy Worksheets("Sheet2").Columns(cel.Column)
Related
Looking for help to achieve searching a range of cells E9:E with All cells containing "Accommodation & Transportation" and changing the value of the cells adjacent to them with 0. , I was not able to get anything online with similar topic and I'm not too good with VBA coding, though i am able to understand what the code will provide in results.
I Have a Commandbutton1 with the below code :
Sub CommandButton1_click()
Dim blanks As Excel.Range
Set blanks = Range("F9:F" & Cells(Rows.Count, 5).End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
blanks.Value = blanks.Offset(0, -1).Value
End Sub
Further i have a command button that will select only cells that are not blank. I need the above result because if the below code selects Non Blank cells from Columns E:F it wont be selecting cells adjacent to those containing "Accommodation & Transportation" as they are blank cells and it will return the error "Runtime Error '1004' This action wont work on multiple selections".
The below code acts the same as [Go to Special => Constants]
Sub SelectNonBlankCells()
Dim rng As Range
Dim OutRng As Range
Dim InputRng As Range
Dim xTitle As String
On Error Resume Next
xTitle = Application.ActiveWindow.RangeSelection.Address
Set InputRng = Range("E8:F500")
ActiveWindow.ScrollRow = 1
For Each rng In InputRng
If Not rng.Value = "" Then
If OutRng Is Nothing Then
Set OutRng = rng
Else
Set OutRng = Application.Union(OutRng, rng)
End If
End If
Next
If Not (OutRng Is Nothing) Then
OutRng.Select
End If
End Sub
Maybe you can try another approach, if your goal is to edit cells adjacent to certain cells. The code below is based on an example in the Help file of the Range.Find function:
Sub DoSomething()
Dim sh As Worksheet
Set sh = ActiveSheet
Dim checkRange As Range
Set checkRange = sh.Range("E8:F500") ' your intended range to search
Dim foundRange As Range
Set foundRange = checkRange.Find("Accommodation & Transportation")
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = checkRange.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub
Or even better, you could add some parameters to make it more reusable:
Sub Main()
DoSomething "Accommodation & Transportation", ActiveSheet.Range("E8:F500")
End Sub
Sub DoSomething(ByVal findWhat As String, ByVal searchWhere As Range)
Dim foundRange As Range
Set foundRange = searchWhere.Find(findWhat)
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = searchWhere.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub
I'm trying to find some macro that will run all over the worksheet and select all the relevant cells.
I have written some macro that find the cell but only one cell-its not selecting all the cells.
Dim myRange As Range
Dim myCell As Range
Set myRange = Range("A1:GG1000")
Dim mynumer As Integer
mynumber = 7
For Each myCell In myRange
If myCell = mynumber Then
myCell.Select
End If
Next myCell
how i can run the macro and see all the relevant cells?
thanks!
Maybe try some .FindNext iteration.
Just adapted from the above link:
Sub Test()
Dim cl As Range, rng As Range
With ThisWorkbook.Sheets("Sheet1").Range("A1:GG1000")
Set cl = .Find(7, LookIn:=xlValues, lookat:=xlWhole)
If Not cl Is Nothing Then
firstAddress = cl.Address
Do
If Not rng Is Nothing Then
Set rng = Union(rng, cl)
Else
Set rng = cl
End If
Debug.Print rng.Address
Set cl = .FindNext(cl)
If cl Is Nothing Then
GoTo DF
End If
Loop While cl.Address <> firstAddress
End If
DF:
rng.Select
End With
End Sub
The question really is, why do you .Select a range? Most of the time that can be avoided, and most likely the code above can be amended to something much cleaner!
Please take a look at this answer:
How to find a value in an excel column by vba code Cells.Find
The answer beneath the top voted, shows you how to search in the whole spreadsheet.
Best regards,
Timo
In need of help in applying the following code below for all sheets. I have tried the code I found online which is ApplyToAllSheets() but I am still new and I don't know how I can make it work. Please help.
Sub ApplyToAllSheets()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
Third wks
Next
End Sub
Sub Third(wks As Worksheet)
Dim Rng As Range
Dim cell As Range
Dim ContainWord As String
With wks
Set Rng = .Range(.Range("B1"), .Range("B" & .Rows.Count).End(xlUp))
End With
'For deleting the remaining informations not necessary
Set Rng = Range("B1:B1000")
ContainWord = "-"
For Each cell In Rng.Cells
If cell.Find(ContainWord) Is Nothing Then cell.Clear
Next cell
Set Rng = Range("C1:C1000")
ContainWord = "2019" 'change to current year
For Each cell In Rng.Cells
If cell.Find(ContainWord) Is Nothing Then cell.Clear
Next cell
Set Rng = Range("A1:A1000")
ContainWord = "-"
For Each cell In Rng.Cells
If cell.Find(ContainWord) Is Nothing Then cell.Clear
Next cell
'For deleting the blanks
On Error Resume Next
ActiveSheet.Range("B:B").SpecialCells(xlBlanks).EntireRow.Delete
On Error GoTo 0
'For shifting the date to the left
Columns("C").Cut
Columns("A").Insert Shift:=xlToLeft
Columns("C").Cut
Columns("B").Insert
'For deleting the negative sign "-"
With Columns("B:B")
.Replace What:="-", Replacement:=""
End With
End Sub
It should successfully apply the code to all the sheets
My result is that the first sheet was always cleared and the other sheets are untouched. please help
You've got unqualified - meaning the Worksheet isn't qualified - Range and Columns calls.
This is good - note the period in front of each instance of Range, as well as before Rows.
With wks
Set Rng = .Range(.Range("B1"), .Range("B" & .Rows.Count).End(xlUp))
End With
This, not so much:
Set Rng = Range("B1:B1000") ' no worksheet specified, so it's the ActiveSheet, not wks.
Or again:
Columns("C").Cut
Move that first End With all the way to the end of the Sub, and add a period in front of each instance of Range and Columns. By doing so, they will reference wks and not imply the ActiveSheet.
While you're at it, change that instance of ActiveSheet to wks. You want to work with wks, not the ActiveSheet.
I'm creating a ranking and I need to delete all the cells with #N/A (pasted as text, not formula) and to delete those cells and shhift them up.
The worksheet contains 503 raws and I need it from column A to T.
Thanks in advance, I have tried so many VBA codes of this web and I'm not able to find something that works.
Try,
dim rng as range
with worksheets("sheet1")
on error resume next
set rng = .range("A:T").specialcells(xlcelltypeformulas, xlerrors)
if not rng is nothing then
rng.delete shift:=xlup
end if
set rng = .range("A:T").specialcells(xlcelltypeconstants, xlerrors)
if not rng is nothing then
rng.delete shift:=xlup
end if
on error goto 0
end with
This should work. There are faster ways of doing what you ask, but since you don't have that big of a data set, I just modified some code I had available.
Sub KillPoundNa()
Dim rCell As Range, WS As Worksheet, KillRng As Range, UndesireableText As String
UndesireableText = "#N/A"
Set WS = ActiveSheet
Set KillRng = WS.Cells(Rows.Count, 1)
For Each rCell In WS.UsedRange.Cells
If InStr(1, rCell.Text, UndesireableText, vbTextCompare) > 0 Then
Set KillRng = Union(KillRng, rCell)
End If
Next rCell
KillRng.Delete (xlUp)
End Sub
I am trying to create a macro that the user will enter their initials in a specific cell and the macro will copy the initials and paste them into a list on another tab. I am having a hard time figuring out how to convert it over to upper case any help is greatly appreciated below is my code. Thanks in advance!
'By Initials
Worksheets("New PN").Activate
Range("B10").Copy
Sheets("PN_List").Select
Range("F1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Selection.HorizontalAlignment = xlCenter
With Selection.Font
.Name = "Calibri"
.Size = 11
End With
right-click your sheet tab PN New
View Code
copy and paste the code below
This code will then automatically add any new value/s from B10 and B12 (second cell used as an example so the code can run on a range if needed) into the first blank cell in column F on sheet *PN_List*
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim lngCnt As Long
Set rng1 = Intersect(Range("B10,B12"), Target)
If rng1 Is Nothing Then Exit Sub
Set rng3 = Sheets("PN_List").Columns("F:F").Find("*", Sheets("PN_List").[f1], xlValues, , xlPrevious, xlByRows)
If rng3 Is Nothing Then Set rng3 = Sheets("PN_List").[f1]
For Each rng2 In rng1
rng3.Offset(lngCnt + 1, 0) = UCase$(rng2)
lngCnt = lngCnt + 1
Next rng2
End Sub
Use the UCASE function. this works for me
ActiveCell = UCase(ActiveCell)
Use Ucase function like this:
Dim initial as String
initial = Ucase(Range("B10").Value)
Range("F1").End(xlDown).Offset(1, 0).Value = initial
Hope this helps.