Find row value, copy row and all the range underneath for data reduction - vba

I am trying to use a macro to clean up data files and only copy on Sheet2 what is most relevant.
I have written the code to find the row I want the data to be copied from. However I can only copy the row itself and not the range underneath. Please note I need the range to go from that row to the last column and last row as the size of the matriz always varies.
s N s N s N s N s rpm
Linear Real Linear Real Linear Real Linear Real Linear Amplitude
0.0000030 9853.66 0.0000030 5951.83 0.0000030 533.48 0.0000030 476.15 0.0000030 2150.16
0.0000226 9848.63 0.0000226 5948.19 0.0000226 557.02 0.0000226 488.60 0.0000226 2150.16
0.0000421 9826.05 0.0000421 5956.22 0.0000421 615.94 0.0000421 480.75 0.0000421 2150.15
0.0000616 9829.72 0.0000616 5989.72 0.0000616 642.59 0.0000616 476.77 0.0000616 2150.15
So basically the code below finds that first row and copies it in Sheet2. I need the macro to also select the range underneath and copy it onto Sheet2. Please can you help me finishing off the script?
Sub SearchForRawData()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 1
LSearchRow = 1
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
While Len(Range("A" & CStr(LSearchRow)).Value) >= 0
'If value in column A = "s", copy entire row to Sheet2
If Range("A" & CStr(LSearchRow)).Value = "s" Then
'Select row and range in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Select all Raw Data underneath found Row to Copy
'Paste all Raw Data into Sheet 2
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A1
Application.CutCopyMode = False
Range("A1").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error has occured"
End Sub

You don't need a loop for this if you want to copy the row that has the "s" and everything below it to the target sheet. The following sub finds the row with the "s" in column A and then copies that row and everything below it to the target sheet.
Note that you should always avoid selecting or activating anything in VBA code, and that the normal way to copy and paste relies on selecting. If you use the syntax I've included here, the clipboard is not used and the target sheet does not need to be selected.
Sub CopyRowAndBelowToTarget()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim match As Range
Set wb = ThisWorkbook
Set src = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
Dim lastCopyRow As Long
Dim lastPasteRow As Long
Dim lastCol As Long
Dim matchRow As Long
Dim findMe As String
' specify what we're searching for
findMe = "s"
' find our search string in column A (1)
Set match = src.Columns(1).Find(What:=findMe, After:=src.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
' figure out what row our search string is on
matchRow = match.Row
' get the last row and column with data so we know how much to copy
lastCopyRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
lastCol = src.Cells(1, src.Columns.Count).End(xlToLeft).Column
' find out where on our target sheet we should paste the results
lastPasteRow = tgt.Range("A" & src.Rows.Count).End(xlUp).Row
' use copy/paste syntax that doesn't use the clipboard
' and doesn't select or activate
src.Range(Cells(matchRow, 1), Cells(lastCopyRow, lastCol)).Copy _
tgt.Range("A" & lastPasteRow)
End Sub

Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
So firstly you don't acutally need the CStr, vba will cast numbers to strings by itself, i.e. Range(LSearchRow & ":" & LSearchRow) should work fine.
To find how many rows down to go use the end function of the range object:
bottomRow = Range("A" & LSearchRow).End(xldown).Row
Do the same for the column
lastCol = Range("A" & LSearchRow).End(xlleft).column
Now to copy:
Range("A" & LSearchRow & ":" & lastCol & bottomRow).Copy
However if you have empty cells inthe middleof the data then instead of using End(xldown), start at the bottom of the sheet and look up:
bottomRow = Range("A1000000").End(xlup).Row
etc

Related

Find Next visible available Row in filtered data VBA

I am trying to write a program, where I must first apply the filter to Column S with 6 possible filter values (1,2,3,4,5,6). Once the filter is applied, I must copy the last used cell in column T and paste the same in the next available (blank) visible cell in column V with the filter still being on.
Once it pastes the values successfully,if I were to apply filter again for the same value, it should repeat the same by finding the next available visible blank cell column V and paste the copied data.
The loop should keep working, For the next instance, based on the condition I might apply the filter for value 2 in the column, I must copy the last used column T data and paste in the next available visible cell in column V with the filter still being on.
I tried many possibilities like End(xlUp) it works only until copying the value from Column T and I am unable to paste it in Column V.I tried using Application.SendKeys method too. It doesn't work all the time.
The following codes that I have pasted down below, I tried copying the value of the last used cell in Column T with End(xlup), which worked all the time, the problem is all about the finding the right next available visible cell in column V to paste the same, sometime it works and sometimes it pastes in the hidden rows
enter image description here
Sub auto_filter2()
Dim ws As Worksheet
Dim ds As Worksheet
Dim SrcLastRow As Long, DestLastRow As Long
Set ws = Worksheets("PVF")
Set ds = Worksheets("Filtered")
Worksheets("PVF").Range("T4").AutoFilter Field:=19, Criteria1:="2"
MsgBox "Its Working"
Sheets("PVF").Select
SrcLastRow = Cells(Rows.Count, "T").End(xlUp).Row
Range("T" & SrcLastRow).Select
Selection.Copy
MsgBox SrcLastRow & " is the row"
Sheets("PVF").Select
Range("V5").End(xlDown).Select
Application.SendKeys "{DOWN}"
Application.SendKeys ("^v{Enter}")
ws.AutoFilterMode = False
End Sub
Sub auto_filter()
Dim ws As Worksheet
Dim ds As Worksheet
Dim SrcLastRow As Long, DestLastRow As Long
Set ws = Worksheets("PVF")
Set ds = Worksheets("Filtered")
Worksheets("PVF").Range("T4").AutoFilter Field:=19, Criteria1:="4"
MsgBox "Its Working"
Sheets("PVF").Select
SrcLastRow = Cells(Rows.Count, "T").End(xlUp).Row
Range("T" & SrcLastRow).Select
Selection.Copy
MsgBox SrcLastRow & " is the row"
Sheets("Filtered").Select
DestLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("C" & DestLastRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Dim cel As Range
With Sheets("PVF")
Set cel = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible)(1, 1)
If cel = "" Then
.Cells(cel.Row, "V") = Sheets("Filtered").Range("C3")
Else
MsgBox (" Non- empty box")
End If
End With
ws.AutoFilterMode = False
End Sub
I hope to solve this problem soon. Many thanks for your solutions in advance.

Copy data from one worksheet to other based on condition

I am trying to copy data from one worksheet to another blank worksheet in a workbook. It has three columns where in I want to search a specific 'Unit' value and just copy all of the records with similar 'Unit' values into second worksheet with similar column structure.
**Doc_number** **Doc_version** **Unit**
43449 01 D013-LAG R
43450 02 D013-LAG R
43451 01 D013-DAMP
43452 02 D013-DAMP
Output should be like this if I provide D013-LAG R as input value ;
**Doc_number** **Doc_version** **Unit**
43449 01 D013-LAG R
43450 02 D013-LAG R
I want to paste the selected column to the DELIVERY sheet like if I pass 'Unit' value as 'D03-LAG R' then the output in the DELIVERY file should be just like as follows;
Doc_version Unit
01 D013-LAG R
02 D013-LAG R
It's more like I want to select entire row and then paste the data to another worksheet to the columns I want to. I don't want entire row to be pasted as it is.
I don't have much experience in VBA and have already tried doing the code which results in copying of the last record encountered in the loop. Need your advice.
Sub Row_Copy()
Dim sheet1 As Worksheet, sheet2 As Worksheet
Dim i As Integer, k As Integer
Dim Sheet1LR As Long, Sheet2LR As Long
Set sheet1 = Sheets("MASTER")
Set sheet2 = Sheets("DELIVERY")
Sheet1LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row + 1
Sheet2LR = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
i = 2
k = Sheet2LR
Do Until i = Sheet1LR
If Trim(sheet1.Cells(i, 26).Value) = "D013-LAG R" Then
With sheet1
.Range(.Cells(i, 1), .Cells(i, 26)).Copy
End With
With sheet2
.Cells(k, 1).PasteSpecial
.Cells(k, 1).Offset(1, 0).PasteSpecial
End With
End If
k = k + 1
i = i + 1
Loop
MsgBox (Complete)
ActiveWorkbook.Save
Application.ScreenUpdating = False
End Sub
This is the latest code I am using;
Sub CommandButton1_Click()
Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim CopyFromSht As Worksheet
Dim CopyToSht As Worksheet
Dim LCnt As Long
On Error GoTo Err_Execute
Set CopyFromSht = Workbooks("TestRow.xlsm").Sheets("MASTER")
Set CopyToSht = Workbooks("TestRow.xlsm").Sheets("DELIVERY")
With CopyFromSht
'Start search in row 4
LSearchRow = .Range("A" & Rows.Count).End(xlUp).Row
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
For LCnt = 2 To LSearchRow
'If value in column Z = "Unit as needed", copy entire row to Sheet2
If .Range("Z" & LCnt).Value = "D013-LAG R" Then
'Select row in Sheet1 to copy
.Rows(LCnt).Copy Destination:=CopyToSht.Rows(LCopyToRow)
'Move counter to next row
LCopyToRow = LCopyToRow + 1
End If
Next LCnt
End With
I wrote a macro that might give you an idea how to resolve your problem:
Sub CopyRows()
' Variables
Dim row_src As Integer
Dim row_dest As Integer
' Inizialize row within destination sheet
row_dest = 1
' Loop over all rows in source sheet
For row_src = 1 To 32767
' Go to correct cell within source sheet
Sheets("Source").Select
Range("B" & CStr(row_src)).Select
' Done if this row is empty
If (ActiveCell.Value = "") Then
Exit For
End If
' Copy row if it's the header or if match found
If (row_src = 1) Or (ActiveCell.Value = "D013-LAG R") Then
' Copy source row
Rows(CStr(row_src) & ":" & CStr(row_src)).Select
Selection.Copy
' Go to destination row
Sheets("Destination").Select
Rows(CStr(row_dest) & ":" & CStr(row_dest)).Select
' Copy row
ActiveSheet.Paste
' Make sure next row is copied on the right place
row_dest = row_dest + 1
End If
Next
End Sub
In case you want to copy only a few columns from the source to the destination sheet, try this:
' Copy columns B to E of source row
Range("B" & CStr(row_src) & ":E" & CStr(row_src)).Select
Selection.Copy
' Go to destination
Sheets("Destination").Select
Range("B" & CStr(row_dest)).Select
' Copy these columns
ActiveSheet.Paste
In case the columns to be copied are not consecutive (for instance B, D and F):
Range("B" & CStr(row_src) & ",D" & CStr(row_src) & ",F" & CStr(row_src)).Select
Range("F" & CStr(row_src)).Activate
Selection.Copy
By the way, I don't know this all by heart.
You can easily find out the details by executing within Excel:
- Menu View/Macro/Register Macro (or something similar; I got the Italian version)
- Do manually anything you want to automate
- Menu View/Macro/Interrput registration
- Menu View/Macro/View/Modify
I hope this helps you

Copy/Paste multiple rows in VBA

I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With

Excel VBA macro to copy specific rows from workbook sheets into new summary sheet....almost works

I need to be able to look at a specified range of cells in every worksheet of my workbook and if they meet criteria, copy that row to a summary sheet. The below code works for the most part except there are a few instances where it copies rows that do not meet the criteria and one instance where it skips a row it should have copied.
Is there a way to use a debug tool so that at any time while cycling through the code I can see: What is the active sheet? What is the active cell? What is the active row? etc.
Also, should I use a -For Each Cell in Range- instead of -While Len- to loop through the specified range on each sheet?
Sub LoopThroughSheets()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim ws As Worksheet
'Start copying data to row 2 in HH (row counter variable)
LCopyToRow = 2
For Each ws In ActiveWorkbook.Worksheets
'Start search in row 7
LSearchRow = 7
While Len(ws.Range("M" & CStr(LSearchRow)).Value) > 0
'If value in column M > 0.8, copy entire row to HH
If ws.Range("M" & CStr(LSearchRow)).Value > 0.8 Then
'Select row in active Sheet to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into HH in next row
Sheets("HH").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to active ws to continue searching
ws.Activate
End If
LSearchRow = LSearchRow + 1
Wend
Next ws
'Position on cell A1 in sheet HH
Sheets("HH").Select
Application.CutCopyMode = False
Range("A1").Select
MsgBox "All matching data has been copied."
End Sub
Very similar to the previous answer just worded differently.Same results though.
Sub Button1_Click()
Dim Rws As Long, Rng As Range, ws As Worksheet, sh As Worksheet, c As Range, x As Integer
Set ws = Worksheets("HH")
x = 2
Application.ScreenUpdating = 0
For Each sh In Sheets
If sh.Name <> ws.Name Then
With sh
Rws = .Cells(Rows.Count, "M").End(xlUp).Row
Set Rng = .Range(.Cells(7, "M"), .Cells(Rws, "M"))
For Each c In Rng.Cells
If c.Value > 0.8 Then
c.EntireRow.Copy Destination:=ws.Cells(x, "A")
x = x + 1
End If
Next c
End With
End If
Next sh
End Sub
For your first question about debugging, you can use:
Debug.Print "Worksheet: " & ActiveSheet.Name
at any time in your code to print out which sheet you are on into the "Immediate" window in the Visual Basic Editor. This is great for debugging in all scenarios.
Second, a For Each loop is the fastest way to loop through anything but it has disadvantages. Namely, if you are deleting/inserting anything it will return funny results (Copy/Paste will be ok). Any sort of While loop is better to use if you don't have a predetermined idea of how many rows you are going to need to work through.
As far as your code is concerned this is how I would do it (you would still need to include your code above and below the while loop):
Dim Items As Range
Dim Item As Range
'This will set the code to loop from M7 to the last row, if you
'didn't want to go to the end there is probably a better way to do it.
Set Items = ws.Range("M7:M26")
For Each Item In Items
'If value in column M > 0.8, copy entire row to HH
If Item.Value > 0.8 Then
'Select row in active Sheet to copy
Item.EntireRow.Copy
'Paste row into HH in next row
Sheets("HH").Rows(LCopyToRow & ":" & LCopyToRow).PasteSpecial
'Move counter to next row
LCopyToRow = LCopyToRow + 1
End If
Next Item

Change formula references during copy

I have a worksheet containing 35 columns of formulas which looks up data from another worksheet. Every time data is entered into the lookup worksheet ("Data") I want to add another set of formulas to the bottom of the row. I've managed to get the code to copy the correct formulas over these 35 columns, to the correct location at the bottom. But when they paste, the exact text of the formulas is copied, rather than changing the cells referenced.
e.g. formula "=OFFSET(Data!$B$1,(A7736-1)*34,0)" copied from row 7736 into row 8300 should become =OFFSET(Data!$B$1,(A8300-1)*34,0) but stays as "=OFFSET(Data!$B$1,(A7736-1)*34,0)"
This is my code
Dim workbk As Workbook
Dim databk As Workbook
Dim MRD As Worksheet
Dim formularrange As Range
Dim lasttrayname As String
Dim datarow As Long
Dim nrow As Long
Dim loopcount As Long
Dim urow As Long
Set workbk = ActiveWorkbook
'set Macro recording information sheet
Set MRD = Worksheets("Macro RunDate")
'find last date updated
urow = Worksheets("Macro RunDate").Range("A" & Rows.Count).End(xlUp).Row
'find last tray used
lasttray = MRD.Range("B" & urow).Value
'find row to paste raw tray data
datarow = Worksheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Do while *condition*
'...More code here....
Loopcount = 0
Loopcount = loopcount + 34
Loop
Go to Tidy:
Tidy:
If loopcount > 0 Then
'convert to correct number of rows to copy
loopcount = (loopcount)/34*8
'copy formulas in Sheet2 for correct number of trays
'determine end row by finding "lasttray"
nrow = Worksheets("Sheet2").Range("A:A").Find(What:=lasttray, _
SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlNext).Row + 8
'repeat formulas
Worksheets("Sheet2").Range(Cells(nrow + 1, "A"), Cells(nrow + loopcount + 1, _
"S")).Formula = Worksheets("Sheet2").Range("A3975:s" & 3975 + loopcount).Formula
'calculate formula values
Worksheets("Sheet2").Range("A:E").Calculate
End If
So my question is, how do I copy these formulas and get the references to change?
Thanks in advance
Instead of setting the Formula property, you could use Copy:
Dim Source As Range
Dim Dest As Range
Set Source = Worksheets("Sheet2").Range("A3975:s" & 3975 + loopcount)
Set Dest = Worksheets("Sheet2").Range(Cells(nrow + 1, "A"), Cells(nrow + loopcount + 1, _
"S"))
Source.Copy Dest
Excel will then increment the row numbers just as it would when copying manually.
Use .FormulaR1C1 rather than .Formula.
– From the comment by #Rory Jun 4 '14 at 13:16
Instead of using cell1 = cell2, do the following:
Range(cell1).Select
Application.CutCopyMode = False
Selection.Copy
Range(cell2).Select
ActiveSheet.Paste
That should paste the relative formula.