Im trying to create a loop in excel that will find a word and then copy and paste all cells underneath the word into another workbook until a blank cell.
Im really new to VBA so please bare with
Sub CopyRows()
Dim Found As Range
Dim NextFreeCell As Range
Dim wkDest As Worksheet
Set wsDest = Workbooks("sample_bills (version 1).xlsx").Worksheets("sample_bills")
Set NextFreeCell = wsDest.Cells(Rows.Count, "C").End(xlUp).Offset(RowOffset:=1)
Set Found = Cells.Find(What:="Paid", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If Found Is Nothing Then
MsgBox "ERROR"
Else
i = Found.Row
j = Found.Column
End If
Do
NextFreeCell = Cells(i, j)
i = i + 1
Loop Until IsEmpty(Cells(i, j))
End Sub
This is what ive got so far but will only copy and paste the word paid into the other workbook, and won't continue to do the rest underneath. Any help would be appreciated :)
Update: Managed to solve this by moving the line
Set NextFreeCell = wsDest.Cells(Rows.Count, "C").End(xlUp).Offset(RowOffset:=1)
into the loop
Related
I have a requirement to automate a step to copy data from one sheet to another using excel macro.
But below are the problem I am facing with this requirement:
Need to copy paste in scope data i.e. filter on 'Data Scope' = Yes
Column sequence of source and target are different and since there are around 127 columns so could not hardcode this part.
Please help if you have a handy code or logic to implement the same.
Found a simple way to implement this, posting it here for others to use.
Sub Reorganize_columns()
Dim v As Variant, x As Variant, findfield As Variant
Dim oCell As Range
Dim rng As Range
Dim iNum As Long
Dim sht_source As Worksheet, sht_target As Worksheet
Set sht_source = ActiveWorkbook.Sheets("Data")
Set sht_target = ActiveWorkbook.Sheets("Macro")
sht_source.Range("A1").AutoFilter Field:=1, Criteria1:="Yes"
Set rng = sht_target.Range("A1:HS1")
For Each cell In rng
iNum = iNum + 1
findfield = cell.Value
Set oCell = sht_source.Rows(1).Find(What:=findfield, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
sht_source.Columns(oCell.Column).Copy
sht_target.Columns(iNum).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next cell
ActiveWorkbook.Save
MsgBox "Completed"
End Sub
Im trying to create a code that will find a particular word on a page and then copy and paste all the cells underneath until a blank cell in another workbook. The only issue i'm finding is that the data shifts when i run it again and there is supposed to be a blank cell.
Sub CopyRows()
Dim Found As Range
Dim ANextFreeCell As Range
Dim BNextFreeCell As Range
Dim wkDest As Worksheet
Set wsDest = Workbooks("sample_bills (version 1).xlsx").Worksheets("sample_bills")
Set Found = Cells.Find(What:="Description", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If Found Is Nothing Then
MsgBox "ERROR"
Else
i = Found.Row
j = Found.Column
End If
Do
Set ANextFreeCell = wsDest.Cells(Rows.Count, "C").End(xlUp).Offset(RowOffset:=1)
Set BNextFreeCell = wsDest.Cells(Rows.Count, "D").End(xlUp).Offset(RowOffset:=1)
ANextFreeCell = Cells(i + 1, j)
BNextFreeCell = Cells(i + 1, j + 1)
i = i + 1
Loop Until IsEmpty(Cells(i, j)) And IsEmpty(Cells(i, j + 1))
End Sub
Any help would be greatly appreciated :)
To find the last row for multiple columns, use Range("C:D").Find, add 1 to get the next empty row.
NextEmptyRow = ActiveSheet.Range("C:D").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
and then paste using...
ActiveSheet.Cells(NextEmptyRow, "C")
I have two spreadsheets. Each spreadsheet contains rows with various bits of information on them, including a unique identifier number (an ISBN in this case).
I am trying to make a script that determines a record is present on the working sheet (obtaining ISBN from column A – working sheet is called ePubWorking), and marks a column (V) on the master sheet (ePubMaster) in the row that contains the same ISBN as found on the previous sheet (the ISBN on the new sheet is also kept in column A). It needs to do this for each record found on the ePubWorking sheet.
I’ve tried a few variants of code I’ve found on here, but I can’t seem to get anything to work. This is what I’m currently working with (which doesn’t appear to be doing anything):
Dim rCell As Range
Dim rFind As Range
Dim iColumn As Integer
For Each rCell In Sheets("ePubWorking").Range("A2", Sheets("ePubWorking").Cells(Rows.Count, "A").End(xlUp))
Set rFind = Sheets("ePubMaster").Rows(1).Find(What:=Trim(rCell.Value), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
rCell.Offset(0, 2).Value = "Sent"
If Not rFind Is Nothing Then
rFind.Offset(0, 21).Value = "Sent"
End If
Next rCell
Nothing is happening using the above (or any of my other variants). I can't even get the "Sent" part to appear on the secondary sheet.
Can anyone point me in the right direction please?
Ok so thanks for the guidance, obviously I'd been banging my head on frankenstein attempts for too long and got blinded to what I was doing. As Zac pointed I was looking along the wrong axis on the ePubMaster sheet.
Working code:
Dim wb As Workbook: Set wb = ThisWorkbook
Dim workingSheet As Worksheet: Set workingSheet = wb.Sheets("ePubWorking")
Dim masterSheet As Worksheet: Set masterSheet = wb.Sheets("ePubMaster")
Dim workingRange As Range: Set workingRange = Range(workingSheet.Range("A2"), workingSheet.Cells(workingSheet.Rows.Count, "A").End(xlUp))
Dim rCell As Range
Dim rFind As Range
For Each rCell In workingRange
If Not rCell.Value = vbNullString Then
Set rFind = masterSheet.Rows.Find(What:=Trim(rCell.Value), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
rCell.Offset(0, 2).Value = "Sent"
If Not rFind Is Nothing Then
rFind.Offset(0, 21).Value = "Sent"
End If
End If
Next rCell
I am trying to use the Range.Find method in VBA to locate the closest previous row number that has a "true" value.
For example, in Column X, there will be a "true" value (row 35), 10 rows with "false," and then "true" again (row 46).
When I get to row 46 in my loop, I need to do a range.find and return row 35.
The code I am using is this:
Worksheets("Data").Cells.Find(True, searchorder:=xlByColumns, searchdirection:=xlNext).Row
What is happening is that I am only finding either the very first "true" value (in this case, row 2), or the very last "true" value (row 24,xxx), as I vary search direction.
What can I do to find only the previous-most "true" value?
You can find the previous row with True by using the After argument in the Find method combined with xlPrevious as the SearchDirection. I have updated the code to add it into a loop, based on your comments.
Since you posted your code, I have edited my answer into your code.
Sub Main()
Dim iCurRow As Long
Dim iCounter As Long
Dim iLastRow As Long
Dim iTempRow As Long
Dim iPreviousRow As Long
Dim iChangeCol As Long
Dim ws As Worksheet
Set ws = Worksheets("Data")
With ws
iChangeCol = .Cells.Find(what:="Change Over?", searchorder:=xlByColumns, searchdirection:=xlNext).Column
iLastRow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
iPreviousRow = 2
For iCounter = 3 To iLastRow
If .Cells(iCounter, iChangeCol).Value = True Then
iTempRow = .Cells.Find(what:=True, After:=.Cells(iCounter, iChangeCol), searchorder:=xlByColumns, searchdirection:=xlPrevious).Row
iPreviousRow = iTempRow
End If
Next iCounter
End With
End Sub
This short snippet uses both the Range.Find method and Range.FindNext method to cycle through all matching cells in column X.
Sub rings_true()
Dim fnd As Range
With Worksheets("Sheet1") `<~~ set this worksheet reference properly
With .Columns(24)
Set fnd = .Find(What:="TRUE", after:=.Cells(.Rows.Count), _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Do While Not fnd Is Nothing
If MsgBox("Currently at " & fnd.Address(0, 0) & Chr(10) & "exit now...?", vbYesNo + vbQuestion) = vbYes Then
Exit Do
Else
Set fnd = .FindNext(after:=fnd)
End If
Loop
End With
End With
End Sub
The current cell address is reported through a MsgBox function. The same MsgBox offers the user the opportunity to break the loop.
Additional error control might include confirming at least one matching value in column X before entering into the loop.
There are multiple arguments to put into the Find method, regarding what you told us, I suggest that you use :
After:=.Cells(.Rows.Count, 1) to start from the bottom of the column
LookIn:=xlValues
LookAt:=xlWhole
SearchOrder:=xlByRows to look row by row (instead of column by column)
SearchDirection:=xlPrevious to look "back", from bottom to top
MatchCase:=False
SearchFormat:=False
And furthermore, you can use the .Find method into a specific range, so rather than Worksheets("Data").Cells.Find(..., you should use Worksheets("Data").Range("X:X").Find(... to look only in the column X.
Here is your amended code :
Sub test_ilarson007()
Dim FirstAddress As String, PreviousMatch As Range, cF As Range
Worksheets("Data").Activate
With Worksheets("Data").Range("X:X")
'First, define properly the Find method
Set cF = .Find(What:=True, _
After:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False, _
SearchFormat:=False)
'If there is a result,
If Not cF Is Nothing Then
FirstAddress = cF.Address
MsgBox "The row containing the previous 'True' in Column X is : " & cF.Row
'keep looking with FindNext method : Not usefull for your example
Do
Set PreviousMatch = cF
Set cF = .FindNext(cF)
'-------------------------------------------------------------
'----Place instructions to execute on the matched cell/row/...
'First match (i.e. Row 46 in your example)
MsgBox PreviousMatch.Row 'Should display 46 (then 35, then ??)
'Second match (i.e. Row 35 in your example)
MsgBox cf.Row 'Should display 35 (then ??, then ??)
'-------------------------------------------------------------
'Look until you find again the first result
Loop While Not cF Is Nothing And cF.Address <> FirstAddress
End If
End With
End Sub
I am having problems with a macro which should search for each mycell of myrange in turn and copy it to another sheet if it is found in the GL sheet. However it continues to run after the cells in myrange (i.e. it continues to run on all the blank rows under myrange). myrange is just 10 rows of data. Here is the code:
Dim myrange As Range
Dim mycell As Range
Set wbProjects = Workbooks("Expense Project Jobs.xlsx")
Set wbGL = Workbooks("GL.xml")
Set wbProjectJournal = Workbooks("Expense Project Journal.xlsx")
wbProjects.Activate
LastrowJob1 = Sheets("Project_Costs").Range("F" & Rows.Count).End(xlUp).Row
Set myrange = Range("F2:F" & LastrowJob1)
'LOOP START
For Each mycell In myrange
If mycell = "" Then
GoTo ErrorHandlerMyCell
End If
mycell.Copy
wbGL.Activate
On Error GoTo ErrorHandlerMyCell
Range("A1").Activate
Cells.Find(What:=mycell, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
On Error GoTo 0
ActiveCell.EntireRow.Cut
wbProjectJournal.Activate
Range("A1").Activate
If Range("A2") <> "" Then
GoTo NextCode2
NextCode2:
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Activesheet.Paste
wbGL.Activate
ActiveCell.EntireRow.Delete
Else
Range("A2").Select
Activesheet.Paste
End If
NextCode1:
Next mycell
ErrorHandlerMyCell:
Resume NextCode1
End Sub
Do you know that your code will run ErrorHandlerMyCell at the end irregardless of whether there's an error or not? It's not a separate module that is called only when there's error but part of the main program which gets triggered. Perhaps you can add a Exit Sub before ErrorHandlerMyCell
Exit Sub
ErrorHandlerMyCell:
Resume NextCode1
End Sub
The code have plenty of redundancies and it seems to be overwriting records copied in Row 3 when cell A2 in wbProjectJournal is empty.
I also suggest to set the worksheets as objects instead of the workbooks. Actually the code ends up working with whatever is the active sheet in the workbooks after they are activated. It could be working now if there is only one sheet or if the one active is the one required, but it’s just a coincidence, not a good practice.
One point to highlight is the excessive and incorrect use of what is intended to act as Error Handlers (see this page On Error Statement for a better understanding), also to improve use of objects see this With Statement
The code below should solve the issue, (have inserted comments to explain the changes):
Option Explicit
Sub TEST_Solution()
Dim wbProjects As Workbook, wbGL As Workbook, wbProjectJournal As Workbook
Dim rTrg As Range, rCll As Range, rCllTrg As Range
Dim rFnd As Range, vWhat As Variant
Set wbProjects = Workbooks("Expense Project Jobs.xlsx")
Set wbGL = Workbooks("GL.xml")
Set wbProjectJournal = Workbooks("Expense Project Journal.xlsx")
wbProjects.Activate
Rem Set Range from wbProjects\Project_Costs\Column F
'use [With] to perform several statements on the same object
'see https://msdn.microsoft.com/en-us/library/office/gg264723(v=office.15).aspx
With wbProjects.Sheets("Project_Costs").Columns(6)
Set rTrg = Range(.Cells(2), .Cells(Rows.Count).End(xlUp))
End With
Rem Search for the value of each cell in the no-empty cells of
For Each rCll In rTrg
Rem Set & Validate cell value
vWhat = rCll.Value2
If vWhat <> Empty Then
Rem Activate range to apply the FIND method
'Replace [1] with the name of the worksheet where the search is run
With wbGL.Sheets(1)
.Application.Goto .Cells(1), 1
Rem Set cell with found value
Set rFnd = .Cells.Find(What:=vWhat, After:=ActiveCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not (rFnd Is Nothing) Then
Rem Activate range to apply the FIND method
'Replace [1] with the name of the worksheet where the search is performed
With wbProjectJournal.Sheets(1).Cells(2, 1)
If .Value2 = Empty Then
Rem A2 = Blank then Paste in row 2 only
rFnd.EntireRow.Copy
.PasteSpecial
Application.CutCopyMode = False
ElseIf .Offset(1).Value2 = Empty Then
Rem A3 = Blank then Paste in row 3 & delete record found
rFnd.EntireRow.Copy
.Offset(1).PasteSpecial
Application.CutCopyMode = False
rFnd.EntireRow.Delete
Else
Rem Paste below last row & delete record found
rFnd.EntireRow.Copy
.End(xlDown).Offset(1).PasteSpecial
Application.CutCopyMode = False
rFnd.EntireRow.Delete
End If: End With: End If: End With: End If: Next
End Sub