I have a code that searches for a value in another shett, after searching i want to copy what the original sheet has bellow in another cells, but i want to oly copy what has information. Then return to the value found and paste bellow last cell with information.
In the sample code the partida.value was found in sheets("bancos") cell = H6
I want to copy the info in Sheets("Bu") B7:C19 and its supposed to get pasted bellow sheets("bancos") G13:h13
Private Sub C1_Click()
Dim Partida As String
Dim Rng As Range
Partida = Worksheets("BU").Range("c3").Value
If Trim(Partida) <> "" Then
With Sheets("Bancos").Rows("6:6")
Set Rng = .Find(What:=Partida, after:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not Rng Is Nothing Then
Worksheets("Bu").Activate
ActiveSheet.Range("b7:c19").Select
'i want to copy only the filled cells in the range (b7:c19); the filled cells in b and c
Selection.Copy
Application.Goto Rng, True
'I want to paste in the last cells with information within the right and below cells from the "rng" found in cells G and H
Else
MsgBox "Not found"
End If
End With
End If
End Sub
No error msg tho
Can you try this. It's untested, but should get you close at least.
Private Sub C1_Click()
Dim Partida As String
Dim Rng As Range, r1 As Range, r As Long, c As Long
Partida = Worksheets("BU").Range("c3").Value
If Trim(Partida) <> "" Then
With Sheets("Bancos").Rows("6:6")
Set Rng = .Find(What:=Partida, after:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not Rng Is Nothing Then
r = Rng.Row + 4
c = Rng.Column - 1
For Each r1 In Worksheets("Bu").Range("b7:c19")
If Len(r1) > 0 Then
.Cells(r, c + r1.Column - 2).Value = r1.Value
r = r + 1
End If
Next r1
Else
MsgBox "Not found"
End If
End With
End If
End Sub
Related
I have a table of data in a sheet that i am looking to make some adjustments to. I have a single column called "S/R" which will have one of two values in it [Serving OR Returning]. If the value is serving i want to copy the value from a column called "1stServeX" to a new column i have added i called "Server 1st Serve X".
I have written the code below but am beginning to trip myself up and also cannot finish the last part. I am a novice and so have been using other pieces of code i have gained previously to try and piece it together, which is why i need some help.
If i can get this going then i can simply repeat it for all the "Returner" option and all the other columns i need to split too.
Thanks in advance for any help offered.
Public Sub splitServerCoordinates()
'Set a constant for the title of the Server Column
Const HEADER_SR As String = "S/R"
Dim ws As Worksheet
Set ws = Sheets("transition")
Dim strSearch As String
Dim aCell As Range
Dim COL_SR As Long
Dim COL_TARGET As Long
Dim COL_CURRENT As Long
'Find the Column Numbers of the columns we are looking for
strSearch = "S/R"
Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
COL_SR = aCell.Column
End If
strSearch = "1stServeX"
Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
COL_CURRENT = aCell.Column
End If
strSearch = "Server 1st Serve X"
Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
COL_TARGET = aCell.Column
End If
Dim theUsedRange As Range
Dim SRRange As Range
Dim aPlayer As Range
Dim serving As String
Dim returning As String
Dim theCounter As Long
Dim theSequence As Long
ws.Select
' clear out the Target column and add the header again
Set theUsedRange = ActiveSheet.UsedRange
Intersect(theUsedRange, Range(Columns(COL_TARGET), Columns(COL_TARGET))).ClearContents
Columns(COL_SR).Range("A1").Value = HEADER_SR
' reset the used range just in case
Set theUsedRange = ActiveSheet.UsedRange
' Get the used range for the S/R column
Set SRRange = Intersect(theUsedRange, Columns(COL_SR))
'Set value to compare to
serving = "Serving"
' Loop through the S/R column
For Each aPlayer In SRRange
' ignore the header row
If aPlayer <> HEADER_SR Then
' if we are serving then copy the value from COL_CURRENT to COL_TARGET
If aPlayer = serving Then
aPlayer.Offset(-1, COL_TARGET - COL_).Value = STUCK - HERE
End If
End If
Next aPlayer
End Sub
Some refactoring to pull out the column header location parts, and a few other tweaks. Untested, but should get you there.
Public Sub splitServerCoordinates()
Dim ws As Worksheet, c As Range
Dim COL_SR As Long
Dim COL_TARGET As Long
Dim COL_CURRENT As Long
Set ws = Sheets("transition")
'Find the Column Numbers of the columns we are looking for
COL_SR = HeaderColumnNumber(ws.Rows(1), "S/R")
COL_CURRENT = HeaderColumnNumber(ws.Rows(1), "1stServeX")
COL_TARGET = HeaderColumnNumber(ws.Rows(1), "Server 1st Serve X", True) 'add if not found
'exit if missing any required columns
If COL_SR = 0 Or COL_CURRENT = 0 Then
MsgBox "Missing 'S/R' and/or '1stServeX' !"
Exit Sub
End If
'reset target column
ws.Columns(COL_TARGET).ClearContents
ws.Cells(1, COL_TARGET).Value = "Server 1st Serve X"
'loop rows
For Each c In ws.Range(ws.Cells(2, COL_SR), ws.Cells(ws.Rows.Count, COL_SR).End(xlUp)).Cells
If c.Value = "Serving" Then
ws.Cells(c.Row, COL_TARGET).Value = ws.Cells(c.Row, COL_CURRENT).Value
End If
Next c
End Sub
'Find a header position on a row, with option to add it if not found
' Returns zero if header is not found and option to add was not set
Function HeaderColumnNumber(rng As Range, hdr As String, _
Optional AddIfMissing As Boolean = False) As Long
Dim f As Range
Set rng = rng.Cells(1).EntireRow 'only want a full row to look in
Set f = rng.Find(What:=hdr, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not f Is Nothing Then
HeaderColumnNumber = f.Column 'found: return column
Else
'not found: do we add it, or return zero?
If AddIfMissing Then
With rng.Cells(rng.Cells.Count).End(xlToLeft).Offset(0, 1)
.Value = hdr
HeaderColumnNumber = .Column
End With
Else
HeaderColumnNumber = 0
End If
End If
End Function
I have two sheets in excel, one is a board with several cells with numbers inside, and the other is references (that have the numbers in previous board) and i need to write in same line of the references where are the cells located.
image of the first board where are the references
image of the excel sheet that i have to write the location of each reference
my vba code
Example:
The arm8.png is the board and local.png is where i write de localizations of the cells
Option Explicit
Sub ciclo()
Dim FindString As String
Dim Rng As Range
Dim matrixVal As Range
Set matrixVal = Sheets("Localizações").Range("B1")
FindString = matrixVal
For Each Rng In matrixVal
If Trim(FindString) <> "" Then
With Sheets("Arm8").Range("A1:J10")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
'Application.Goto Rng, False
'MsgBox Rng.Column & " - " & Rng.Row
Else
MsgBox "Nothing found"
End If
End With
With Sheets("Localizações")
.Range("C1:C9").Value = Rng.Column
.Range("D1:D9").Value = Rng.Row
End With
End If
Next Rng
End Sub
I expected the output in local.png to be column C and D
2 - 9
2 - 7
2 - 8
2 - 4
5 - 4
7 - 4
5 - 9
9 - 7
9 - 0
Firstly, as I said in my comment, this:
Set matrixVal = Sheets("Localizações").Range("B1")
sets matrixVal as one single cell (B1 to be precise), so your For-Each loop doesn't have any cells to loop through apart from this single cell, so it will only run once.
Second, the FindString needs to be updated inside the loop, otherwise you'll be searching for the same value over and over.
Finally, you shouldn't update the Rng variable inside the loop because you are already using it to loop through a range. You need a second variable of type Range.
Your code should look like:
Sub ciclo()
Dim FindString As String
Dim Rng As Range
Dim cell As Range
Dim matrixVal As Range
Set matrixVal = ThisWorkbook.Worksheets("Localizacoes").Range("B1:B9")
For Each cell In matrixVal
FindString = cell.Value
If Trim(FindString) <> "" Then
With ThisWorkbook.Worksheets("Arm8").Range("A1:J10")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
With ThisWorkbook.Worksheets("Localizacoes")
.Cells(cell.Row, "C").Value = Rng.Column
.Cells(cell.Row, "D").Value = Rng.Row
End With
Else
MsgBox "Nothing found"
End If
End With
End If
Next cell
End Sub
I have code that matches the string and copies it to the next sheet. But when i make changes so that it pastes the value in the same sheet but different column it doesn't work. I am trying to match the array in the red part and copying it into the C column
Option Explicit
Sub SearchForString()
Dim a As Long, arr As Variant, fnd As Range, cpy As Range, addr As
String
On Error GoTo Err_Execute
'populate the array for the outer loop
arr = Array("trigger")
With Worksheets("test")
'outer loop through the array
For a = LBound(arr) To UBound(arr)
'locate first instance
Set fnd = .Columns("A").Find(what:=arr(a), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not fnd Is Nothing Then
'record address of first find
addr = fnd.Address
'seed the cpy range object
If cpy Is Nothing Then Set cpy = fnd.EntireRow
Do
'build union
Set cpy = Union(cpy, fnd.EntireRow)
'look for another
Set fnd = .Columns("A").FindNext(after:=fnd)
'keep finding new matches until it loops back to the first
Loop Until fnd.Address = addr
End If
Next a
End With
With Worksheets("test")
'one stop copy & paste operation
cpy.Copy Destination:=.Cells(.Rows.Count, "c").End(xlUp).Offset(1, 0)
End With
MsgBox "All matching data has been copied."
Exit Sub
End Sub
I'm new to VBA in Excel and have a fairly simple issue. I need to search for specific text string Bath in Column B. If it exists, then I need to replace specific text string KCab in Column C of the same row with BCab3. I need to run or loop this until it checks all the cells in Column B.
Here is what I have so far, which is not working:
Sub Correct_Attribute_Suffix()
Dim c As Range
Dim SrchRng
Set SrchRng = ActiveSheet.Range("B3", ActiveSheet.Range("B65536").End(xlUp))
Do
Set c = SrchRng.Find("BATH", LookIn:=xlValues)
If Not c Is Nothing Then Currentcell.Offset(, 1).Value = Replace("KCab", "K", "B")
Loop While Not c Is Nothing
End Sub
This is just a Find/FindNext operation using offset and replace to accomplish your attribute suffix adjustment.
Sub Correct_Attribute_Suffix()
Dim fnd As Range, addr As String
With ActiveSheet.Range("B3", ActiveSheet.Range("B65536").End(xlUp))
Set fnd = .Find(What:="BATH", After:=.Cells(.Cells.Count), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not fnd Is Nothing Then
addr = fnd.Address
Do
fnd.Offset(0, 1) = Replace(fnd.Offset(0, 1).Value2, "KCab", "BCab3", 1, 1, vbTextCompare)
Set fnd = .FindNext(After:=fnd)
Loop While addr <> fnd.Address
End If
End With
End Sub
I'm trying to put a "X" or what ever in a the next empty column that I later can use INDEX and INDERECT (since the sheets are named the same as the range in column A in my main sheet) to look up for my main sheet. The "X" needs to be added in each of the sheets where the value is found.
The column in the sheets where the numbers I need to find the value is always in column A. In my main sheet the values are listed from B2:B23. The range varies in each sheet (from 400 to 5000 rows).
Is there a clever way of doing this that I haven't found still?
atm there are 80 sheets and the one main sheet
Code:
Sub Mark_cells_in_column()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim I As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Search for a Value Or Values in a range
MyArr = Array("34-2472", "36-437", "36-4351", "36-4879", "36-4982", "36-4981" _
, "36-5715", "36-4983", "36-4984", "36-5125", "36-5126", "36-5257", "36-6139" _
, "38-7079-1", "38-7079-2", "44-1276", "31-8589", "31-8589-1", "31-8647", "36-6149" _
, "36-5770", "31-8590")
'Search Column or range
With Sheets("3").Range("A:A") 'cant get my head around how to get this to apply so it loops through every sheet except main sheet
'clear the cells in the column to the right
.Offset(0, 13).ClearContents
For I = LBound(MyArr) To UBound(MyArr)
'If you want to find a part of the rng.value then use xlPart
'if you use LookIn:=xlValues it will also work with a
'formula cell that evaluates to "values listed"
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
'mark the cell in the column to the right if "Values listed" is found
Rng.Offset(0, 13).Value = "X"
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Here you go:
Sub Mark_cells_in_column()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim I As Long
Dim mainWS As Worksheet, ws As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set mainWS = Sheets("Main") ' Change this to whatever the name of your Main WS is, that you DON'T want to run the macro on
'Search for a Value Or Values in a range
MyArr = Array("34-2472", "36-437", "36-4351", "36-4879", "36-4982", "36-4981" _
, "36-5715", "36-4983", "36-4984", "36-5125", "36-5126", "36-5257", "36-6139" _
, "38-7079-1", "38-7079-2", "44-1276", "31-8589", "31-8589-1", "31-8647", "36-6149" _
, "36-5770", "31-8590")
' Loop through Sheets
For Each ws In Worksheets
If ws.Name <> mainWS.Name Then
With ws
'Search Column or range
With .Range("A:A")
'clear the cells in the column to the right 13 columns (aka column N)
.Offset(0, 13).ClearContents
For I = LBound(MyArr) To UBound(MyArr)
'If you want to find a part of the rng.value then use xlPart
'if you use LookIn:=xlValues it will also work with a
'formula cell that evaluates to "values listed"
Set Rng = .Cells.Find(What:=MyArr(I), _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
'mark the cell in the column to the right if "Values listed" is found
Rng.Offset(0, 13).Value = "X" ' This marks it in 13 columns to the right where the value is found
Set Rng = .Columns("A:A").FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With ' Ends the .Range("A:A")
End With ' ends the `with WS`
End If
Next ws
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
The main thing seemed to be you were using the very last cell (After:=.Cells(.Cells.Count)) with SearchDirection:=xlNext. ...there's no next cell, if you're at the end! So, I changed that to After:=.Cells(1,1).
Secondly, I added a loop to check the worksheets, and if it's "Main", skip it. Edit as required.