I'm fairly new to VBA and I'm having a lot of trouble doing a seemingly easy task. I've tried many different codes using this website and this is the one that gets me closest to what I want but it doesn't return any values. Here is the premise of what I need it to do:
1) Search the entire first row of columns (A1 to let's say Z1) of a worksheet for specific text such "Closed"
2) If the desired text "Closed" is found in one of the columns, copy all the values from that column
3) Paste those values from the column into Column J of another worksheet ("Source_Workbook")
****EDIT**: I want the column data to paste starting at the next empty row after row 5 of column J (10). I was having trouble using "Offset" in this case. Also, I want only the values to be pasted (keep the formatting of the page onto which the data is being pasted).
My problem is that this code keeps giving me errors when I try to do "Range.PasteSpecial." I hope I have the right approach. Please let me know if I can clarify anything further.
Dim rng As Range
Dim cl As Object
Dim strMatch As String
strMatch = "Closed" 'Search first row for columns with "Closed"
Set rng = Target_Workbook2.Sheets(2).Range("A1:Z1")
For Each cl In rng
If cl.Value = strMatch Then
cl.EntireColumn.Copy
Exit For
With Source_Workbook2.Sheets(2)
Sheets(2).Columns("J").Offset(5, 0).PasteSpecial xlPasteValues
End With
End If
Next cl
Would
Target_Workbook2.Sheets(2).Range("A1:Z1").AutoFilter 1, "*Closed*"
possibly work better for filtering?
You are exiting for loop before pasting the values on Sheet2.
Try this code:
Dim rng As Range
Dim cl As Object
Dim strMatch As String
strMatch = "Closed" 'Search first row for columns with "Closed"
Set rng = Target_Workbook2.Sheets(2).Range("A1:Z1")
For Each cl In rng
If cl.Value = strMatch Then
cl.EntireColumn.Copy Destination:=Sheets("Sheet2").Columns(10)
Exit For
End If
Next cl
Edit 1: Based on the comment
This will copy the column and paste it from row 5 on Sheet2.
Dim rng As range
Dim cl As Object
Dim strMatch As String
Dim lastrow As Long
Dim sh2lastrow As Long '<-- Newly added
Dim col As Long '<-- Newly added
Dim range As range '<-- Newly added
strMatch = "Closed" 'Search first row for columns with "Closed"
lastrow = Sheets("Sheet1").range("A65536").End(xlUp).Row ' or + 1
sh2lastrow = Sheets("Sheet2").range("J65536").End(xlUp).Row + 4 '<-- Newly added (Because you want to start from row 5)
Set rng = Sheets("Sheet1").range("A1:Z1")
For Each cl In rng
If cl.Value = strMatch Then
lastrow = Cells.CurrentRegion.Rows.Count '<-- (Getting row count of given column)
col = cl.Column '<-- (Getting column number of given column)
With Sheets("Sheet1")
Set range = .range(.Cells(2, col), .Cells(lastrow, col)) '<-- (Setting up the range to copy)
End With
range.Copy
Sheets("Sheet2").Activate '<-- Newly added
Sheets("Sheet2").range("J" & sh2lastrow).PasteSpecial xlPasteValues '<-- (Pasting the copied data)
sh2lastrow = Sheets("Sheet2").range("J65536").End(xlUp).Row + 1 '<-- (Getting the last row from Sheet2)
Sheets("Sheet1").Activate
End If
Next cl
Related
I need to find the value of the last cell in column b of sheet1. This value will change weekly. I then want to take that value and find it in sheet2. Then I want to copy and paste all data below this found value to sheet3. I can't get past the first part with the following code:
Dim cell As Range
Dim rangefound As Integer
Dim lastRow As Long
lastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Set cell = Range("B:B").Find("rangefound")
rangefound = lastRow = Cells(lastRow, 2).Value
I've been struggling with the syntax for a month and really don't know what I'm doing.
try this
Sub test()
Dim cell As Range
Dim rangefound As Integer
Dim lastRow As Long
lastRow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
rangefound = Sheet1.Cells(lastRow, 2).Value
Set cell = Sheet2.Range("B:B").Find(rangefound)
MsgBox "The value was found in Sheet2!" & cell.Address
End Sub
The issues with your code were
using rangefound before it had a value, i.e. the order of the commands
using "rangefound" as a text instead of the variable
wrong syntax to assign a value to rangefound
not qualifying which sheet should be searched
Edit: To extend the code to copy the data below the found value to another sheet, use Offset to reference one row below. There are many different ways to do this, so using Offset is just one option.
Here is the complete code
Sub test()
Dim mycell As Range, RangeToCopy As Range
Dim rangefound As Integer
Dim lastRow As Long
lastRow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
rangefound = Sheet1.Cells(lastRow, 2).Value
' this is the cell with the found value
Set mycell = Sheet2.Range("B:B").Find(rangefound)
' now find the last row in Sheet2. We can use lastRow again,
' since it is no longer needed elsewhere
lastRow = Sheet2.Range("B" & Rows.Count).End(xlUp).Row
' set the range to copy to start one cell below rangefound
' to the end of the data in column B
Set RangeToCopy = Sheet2.Range(cell.Offset(1, 0), Sheet2.Cells(lastRow, "B"))
' copy the range and paste into Sheet3, starting at A1
RangeToCopy.Copy Sheet3.Range("A1")
End Sub
Note: I changed the variable name from "cell" to "mycell". It's better to use variable names that cannot be mistaken for Excel artifacts.
Another edit: If you need to paste into the next free row in Sheet3, use the techniques already established.
[...]
Set RangeToCopy = Sheet2.Range(cell.Offset(1, 0), Sheet2.Cells(lastRow, "B"))
' get the next available row in Sheet3
lastRow = Sheet3.Range("A" & Rows.Count).End(xlUp).Row + 1
' copy and paste
RangeToCopy.Copy Sheet3.Range("A" & lastRow)
[...]
Note that I'm using the same variable for three different purposes. If that is too confusing, create three distinct variables instead.
I have this code (see below) that finds if a column in the front of a sheet must be deleted when all the columns which needed to be deleted are deleted. the code finds the last used column and refills the sheet until it reaches column DO.
But now, when the column is already filled from the last time I pressed the button and no rows got deleted. the code crashes and says
Error 1004 while executing. Methode Autofill of class Range failed.
It only works when the column DO is not used yet.
This is my code:
Dim lColumn As Long
Dim iCntr As Long
lColumn = 20
For iCntr = lColumn To 12 Step -1
If Cells(3, iCntr) = 0 Then
Columns(iCntr).Delete
End If
Next
With Workbooks("Bureauplanning2backup.xlsm").Worksheets("Planning")
Dim rngStart As Range
Set rngStart = .Cells(2, .Columns.Count).End(xlToLeft).Offset(,
-1).EntireColumn
Dim rngEnd As Range
Set rngEnd = .Cells(2, .Columns.Count).End(xlToLeft).EntireColumn
Dim rng As Range
Set rng = .Range(rngStart, .Columns("DO"))
Dim rngX As Range
Set rngX = .Range(rngStart, rngEnd)
End With
rngX.AutoFill rng, Type:=xlFillDefault
Is there a way to check if column DO is already filled and when it is filled the code just does not run the line:
rngX.AutoFill rng, Type:=xlFillDefault
You can count how many cells in DO have data
If Application.WorksheetFunction.CountA(.Columns("DO")) = 0 Then
'zero cells have data so autofill
rngX.AutoFill rng, Type:=xlFillDefault
Else
'at least one cell has data so don't autofill
MsgBox "Column DO has already data"
End If
I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.
The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.
There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.
Below is the code:
Sub copyrows()
Dim tfRow As Range, cell As Object
Set tfRow = Range("A1:A") 'Range which includes the values
For Each cell In tfRow
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P2").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Sub copyrows2()
Dim tfRow2 As Range, cell As Object
Set tfRow2 = Range("A1:A") 'Range which includes the values
For Each cell In tfRow2
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P5").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
As #urdearboy mentioned in the commnets above, you need to add a row to your second A column range to avoid getting the error.
To merge two conditions, in your case add an Or to your If.
To run the code faster, don't Select and Activate different sheets, it takes a long time for the code to run. Instead, use a Range object, like CopyRng and every time the if criteria is ok, you add that cell to the range using the Union function.
Read HERE about the Union functionality.
More comments inside the code's notes below.
Modified Code
Option Explicit
Sub copyrows()
Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long
Set Sht1 = Sheet1
Set Sht3 = Sheet3
With Sht1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A
Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values
For Each C In tfRow
If IsEmpty(C) Then
Exit Sub
End If
If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng, C) ' use Union to merge multiple ranges
Else
Set CopyRng = C
End If
End If
Next C
End With
' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
' get last row with data in "sheet3"
LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row
CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If
End Sub
Data is transferred from a web-form to Excel. Not every cell receives inputs. There are many cells, it is time consuming to scan each cell looking for text.
How do I get the text automatically copied from sheet1 to sheet2. But I don't want the cells displayed in the same layout as the original sheet. I would like them to be grouped together, eliminating all of the empty cells in between. I would also like to grab the title from the row that contains the text.
I found this macro:
Sub CopyC()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("C1:C10")
For Each cel In SrchRng
If cel.Value <> "" Then
cel.Offset(2, 1).Value = cel.Value
End If
Next cel
It grabs only cells that contain text, but it displays it in the exact same layout that it found it in. Any help would be appreciated and save me a lot of scan time in the future, thanks in advance :)
I guess this is what you are looking for:
Sub CopyNonBlankCells()
Dim cel As Range, myRange As Range, CopyRange As Range
Set myRange = Sheet1.Range("C1:C20") '---> give your range here
For Each cel In myRange
If Not IsEmpty(cel) Then
If CopyRange Is Nothing Then
Set CopyRange = cel
Else
Set CopyRange = Union(CopyRange, cel)
End If
End If
Next cel
CopyRange.Copy Sheet2.Range("C1") '---> enter desired range to paste copied range without blank cells
End Sub
Above code will copy range C1:C20 in Sheet1 to C1 in Sheet2
Got this from here.
EDIT: Following answer is based on your comment
________________________________________________________________________________
If you'll write something like below
Set myRange = Sheet1.Range("G:G")
Set myRange = Sheet2.Range("G:G")
myRange will be first set to Sheet1.Range("G:G") and then to Sheet2.Range("G:G") that means current range that myRange will have is Sheet2.Range("G:G").
If you want to use multiple ranges you can go for UNION function but there's a limitation that using UNION, you can combine different ranges but of only one sheet. And your requirement is to combine ranges from different sheets. To accomplish that I am adding a new worksheet and adding your G:G ranges from all the sheets to it. Then after using newly added sheet I am deleting it.
Following code will give you the desired output in the sheet named Result.
Sub CopyNonBlankCells()
Dim cel As Range, myRange As Range, CopyRange As Range
Dim wsCount As Integer, i As Integer
Dim lastRow As Long, lastRowTemp As Long
Dim tempSheet As Worksheet
wsCount = Worksheets.Count '--->wsCount will give the number of Sheets in your workbook
Set tempSheet = Worksheets.Add '--->new sheet added
tempSheet.Move After:=Worksheets(wsCount + 1)
For i = 1 To wsCount
If Sheets(i).Name <> "Result" Then '---> not considering sheet "Result" for taking data
lastRow = Sheets(i).Cells(Rows.Count, "G").End(xlUp).Row '--->will give last row in sheet
lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row '--->will give last row in newly added sheet
Sheets(i).Range("G1:G" & lastRow).Copy _
tempSheet.Range("G" & lastRowTemp + 1).End(xlUp)(2)
End If
Next i
lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row
Set myRange = tempSheet.Range("G1:G" & lastRowTemp) '--->setting range for removing blanks cells
For Each cel In myRange
If Not IsEmpty(cel) Then
If CopyRange Is Nothing Then
Set CopyRange = cel
Else
Set CopyRange = Union(CopyRange, cel)
End If
End If
Next cel
CopyRange.Copy Sheets("Result").Range("G1") '---> enter desired range to paste copied range without blank cells
Application.DisplayAlerts = False
tempSheet.Delete '--->deleting added sheet
Application.DisplayAlerts = True
End Sub
You can use arrays!
Instead of copying information from one cell to another, you can store all your information in an array first, then print the array on another sheet. You can tell the array to avoid empty cells. Typically, using arrays is the best way to store information. (Often the fastest way to work with info)
If you are only looking at one column, you could use a one-dimensional array. If you are looking at multiple columns, and want to print the information into the corresponding column (but different cells) in another page then you could a multi-dimensional array to store column number/anything else you wanted.
From your code, it could look like this:
Sub CopyC()
Dim SrchRng As Range, cel As Range
'Declare your 1-d array (I don't know what you are storing)
Dim myarray() as variant
Dim n as integer
Dim i as integer
Set SrchRng = Range("C1:C10")
'define the number of elements in the array - 1 for now, increase it as we go
n = 0
Redim myarray(0 to n)
For Each cel In SrchRng
If cel.Value <> "" Then
'redim preserve stores the previous values in the array as you redimension it
Redim Preserve myarray(0 to n)
myarray(n) = cel.Value
'increase n by 1 so next time the array will be 1 larger
n = n + 1
End If
Next cel
'information is now stored, print it out in a loop
'this will print it out in sheet 2 providing it is called "Sheet2"
For i = 0 to ubound(myarray)
Sheets("Sheet2").cells(i,1).value = myarray(i)
Next i
For a project I am working on, I am attempting to copy a row from an excel spreadsheet, only if the correct criteria are met.
For example,
I need to copy a row that has the following items in them:
Fruit, Apple, True, Cell<4
I've tried using something like
Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch
Set SrchRng = ActiveSheet.Range("A4:T60", ActiveSheet.Range("A60:T60").End(xlUp))
For Each strSearch In Array("Apple")
Set c = SrchRng.Find(strSearch, LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Copy
Sheets("Results").Paste
Next strSearch
End Sub
But the problem with this is that it only searches for a single criteria: Apple. I need the script to scan the whole row for all filters to be correct, then copy the row.
The script I used also only copies the row once, and does not seem to copy all rows that include Apple.
I am assuming that your data is consistent i.e. you are looking for Fruit in one column, Apple in another column and likewise for TRUE and <4.
Here in the code I am looking for Fruit in Column A, Apple in Column B, TRUE in Column C and <4 in Column D. You can change column numbers as required.
I've named the sheet where data is as Data and the sheet to paste copied rows as Results
Sub CopyRow()
Dim LastRowCurr As Long, LastRowResult As Long
Dim LastColumn As Long
Dim i As Long
Dim currWS As Worksheet, resultWS As Worksheet
Dim MyRange As Range
Set currWS = ThisWorkbook.Sheets("Data") '---> sheet where data is
Set resultWS = ThisWorkbook.Sheets("Results") '---> sheet to paste copied rows
lastRow = currWS.Cells(Rows.Count, "A").End(xlUp).Row
LastRowResult = resultWS.Cells(Rows.Count, "A").End(xlUp).Row
With currWS
For i = 4 To lastRow
'change column numbers in the below line as required
If .Cells(i, 1).Value = "Fruit" And .Cells(i, 2).Value = "Apple" And .Cells(i, 3).Value = True And .Cells(i, 4).Value < 4 Then
.Rows(i).Copy Destination:=resultWS.Range("A" & LastRowResult)
LastRowResult = LastRowResult + 1
End If
Next i
End With
End Sub
I guess this is what you want.
you have to add another loop for the .find function. On your Code it only looks once for Apples. What you have to do is, you have to add another loop and repeat the .find function until you this .find function gives your the first match again . Try something like this:
Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch
Dim wsResults As Worksheet
Dim firstAddress
Set SrchRng = ActiveSheet.Range("A1:T60", ActiveSheet.Range("A60:T60").End(xlUp))
Set wsResults = ThisWorkbook.Worksheets("Results")
For Each strSearch In Array("Apple")
Set c = SrchRng.Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.EntireRow.Copy wsResults.UsedRange.Cells(wsResults.UsedRange.Rows.Count + 1, 1)
Set c = SrchRng.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next strSearch
End Sub