This code is working to copy the filtered data of "Award" column marked "Yes" to another sheet; however, I'm receiving an error of "Type Mismatch." I'm not 100% now that the code is working properly to filter the data and copy correctly. I currently have 23 rows of test data for proper functionality. If I only put one row of data, then it doesn't copy and paste the data correctly. I am left with the copied 1st row of data plus the 2nd empty row of data. Additionally, it is not clearing the contents of the rows after the paste, so I may add new data as the days progress.
Sub CopySheet()
Dim i As Integer
Dim LastRow As Integer
Dim Search As String
Dim Column As Integer
Sheets("MasterData").Activate
Sheets("MasterData").Range("A1").Select
'Sets an Autofilter to sort out only your Yes rows.
Selection.AutoFilter
'Change Field:=5 to the number of the column with your Y/N.
Sheets("MasterData").Range("$A$1:$G$200000").AutoFilter Field:=7, Criteria1:="Yes"
'Finds the last row
LastRow = Sheets("MasterData").Cells(Sheets("MasterData").Rows.Count, "A").End(xlUp).row
i = 1
'Change the 3 to the number of columns you got in Sheet2
Do While i <= 11
Search = Sheets("ActiveJobStatus").Cells(1, i).Value
Sheets("MasterData").Activate
'Update the Range to cover all your Columns in MasterData.
If IsError(Application.Match(Search, Sheets("MasterData").Range("A1:G1"), 0)) Then
'nothing
Else
Column = Application.Match(Search, Sheets("MasterData").Range("A1:G1"), 0)
Sheets("MasterData").Cells(2, Column).Resize(LastRow, 1).Select
Selection.Copy
Sheets("ActiveJobStatus").Activate
Sheets("ActiveJobStatus").Cells(2, i).Select
ActiveSheet.Paste
End If
i = i + 1
Loop
'Clear all Y/N = Y
'Update the Range to cover all your Columns in MasterData.
Sheets("MasterData").Activate
Column = Application.Match("Award", Sheets("MasterData").Range("A1:F1"), 0)
Sheets("MasterData").Cells(2, Column).Resize(LastRow, 1).Select
Selection.ClearContents
End Sub
Sorry to change your code up so much, but it looks like you might be over-complicating how to do it.
This is some code from a previous question I answered where someone wanted to highlight a specific range whenever the word "Total" was found.
I changed the find to "Yes". Change the SearchRange to your column. (I think G is right).
Also, for future reference, Select should [almost never] be used.
It slows down code execution quite a bit and is not required.
I know the macro recorder likes to use it, but everything can be referenced without using select.
Brief example:
Sheets("ActiveJobStatus").Activate
Sheets("ActiveJobStatus").Cells(2, i).Select
ActiveSheet.Paste
Can Be replaced by:
Sheets("ActiveJobStatus").Cells(2, i).Paste
This code is working to copy the filtered data of "Award" column marked "Yes" to another sheet.
Sub CopyAwardsToActiveJobStatusSheet()
Dim SearchRange, First, Finder As Range
Dim PasteRow as Integer 'Add this to increment the rows we paste your data to
Set SearchRange = Sheets("MasterData").Range("G:G") 'Search This Range for "Yes"
Set Finder = SearchRange.Find("Yes") 'This is what we're looking for
If Finder Is Nothing Then Exit Sub 'We didn't find any "Yes" so we're done
'Drastically increases speed of every macro ever
'(well, when the sheets are modified at least - and it doesn't hurt)
Application.ScreenUpdating = False
First = Finder.Address 'Grab the address of the first "Yes" so we know when to stop
'Get the last row of column "A" on ActiveJobStatusSheet and start pasting below it
PasteRow = Sheets("ActiveJobStatus").Cells(Sheets("ActiveJobStatus").Rows.Count, "A").End(xlUp).Row + 1
Do
'Copy the entire row and paste it into the ActiveJobStatus sheet
'Column A and PasteRow (the next empty row on the sheet)
'You can change these if needed
Finder.EntireRow.Copy Sheets("ActiveJobStatus").Range("A" & PasteRow)
'If you just want A:G, you can use this instead:
'Finder returns the cell that contains "Yes",
'So we offset/resize to get the 6 cells before it and just copy that
'Resize doesn't like negative numbers so we have to combine:
'Finder.Offset(,-6).Resize(,7).Copy Sheets("ActiveJobStatus").Range("A" & PasteRow)
'Look for the next "Yes" after the one we just found
Set Finder = SearchRange.FindNext(after:=Finder)
PasteRow = PasteRow + 1 'Faster than looking for the end again
'Do this until we are back to the first address
Loop While Not Finder Is Nothing And Finder.Address <> First
'Clear MasterData
Sheets("MasterData").Range("A2:G" & Sheets("MasterData").UsedRange.Rows.Count).ClearContents
Application.ScreenUpdating = True 'Drastically increases speed of every macro ever.
End Sub
Just the code:
Sub CopyAwardsToActiveJobStatusSheet()
Dim SearchRange, First, Finder As Range
Dim PasteRow as Integer
Set SearchRange = Sheets("MasterData").Range("G:G")
Set Finder = SearchRange.Find("Yes")
If Finder Is Nothing Then Exit Sub
Application.ScreenUpdating = False
First = Finder.Address
PasteRow = Sheets("ActiveJobStatus").Cells(Sheets("ActiveJobStatus").Rows.Count, "A").End(xlUp).Row + 1
Do
Finder.EntireRow.Copy Sheets("ActiveJobStatus").Range("A" & PasteRow)
Set Finder = SearchRange.FindNext(after:=Finder)
PasteRow = PasteRow + 1
Loop While Not Finder Is Nothing And Finder.Address <> First
Sheets("MasterData").Range("A2:G" & Sheets("MasterData").UsedRange.Rows.Count).ClearContents
Application.ScreenUpdating = True
End Sub
Results:
MasterData Sheet:
ActiveJobStatus Sheet:
Related
I am putting together a project management excel spreadsheet (my company won't fork out for licenses for everyone to have access to anything like MS Project or suchlike, and I'd like something everyone can use), and would like the user to be able to add or delete rows wherever they specify (I'm using a userform to make it easier to use). I am having issues copying, cutting and pasting rows to allow for a new blank row.
I want the user to specify the row number where they want to place a new row (with all associated formulae and formatting). At present I'm using Cell "C6" to input the Row number. I'm using a modified variant of code I've successfully used previously which allowed me to copy and paste a new blank row at the bottom of a spreadsheet. I'd like my modified code to copy all rows in the range between the row specified in cell "C6" and the last full row, then offset by one row and paste e.g. if the first row value is 14, and the last row is 50, copy the range(14:50), offset to row 15 and paste.
Once I get this bit right I'll then do the rest of the code to copy/paste and clear into row 14 to give me a new blank formatted row. I'm hoping the code to delete a row will be something along the lines of this in reverse, but I'll get to that later.
At the moment I'm consistently getting an error which I just don't understand - I've tried everything I know to resolve this, and carried out numerous Google searches, but nothing is working!
The error keeps highlighting the 'FirstRow' as an issue, but I've got a number in the cell - I'm at a loss:
Dim rActive As Range
Dim FirstRow As Integer
Dim LastRow As Integer
Set rActive = ActiveCell
Application.ScreenUpdating = False
FirstRow = Range(Range("C6").Value)
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
With Range(FirstRow & ":" & LastRow)
.Copy
With Range(FirstRow).Offset(1, 0)
.PasteSpecial xlPasteAll
On Error Resume Next
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
I can see that the correct range is selected and copied, but there is an issue with the subsequent offset.
There is a mix up in your variable types
FirstRow = Range(Range("C6").Value) will return a RANGE OBJECT (actually it will error because there is no "set").
FirstRow = Range("C6").Value will return an INTEGER OR STRING.
++++++++++++++++++++++++++++++++++
I've done something similar, it isn't the most stellar code, but maybe it will give you some ideas.
Sub AddParticipant()
Dim msgChoice As VbMsgBoxResult
Dim NewName As String
Dim TargetCell As Range
'Set Up
ThisWorkbook.Save
If Range("LastParticipant").Value <> "" Then
MsgBox "The roster is full. You cannot add anymore participants.", vbCritical
Exit Sub
End If
'Get Name
NewName = Application.InputBox( _
Prompt:="Type the participant's name as you would like it to appear on
this sheet.", _
Title:="Participant's Name", _
Type:=2)
'Error Message
If NewName = "" Then
MsgBox ("You did not enter a name.")
Exit Sub
End If
'Get Location (with Data Validation)
GetTargetCell:
Set TargetCell = Application.InputBox _
(Prompt:="Where would you like to put this person? (Select a cell in
column A)", _
Title:="Cell Select", _
Type:=8)
If TargetCell.Count > 1 Then
MsgBox "Select a single cell in Column A"
GoTo GetTargetCell
End If
If TargetCell.Column <> 1 Then
MsgBox "Select a single cell in Column A"
GoTo GetTargetCell
End If
If TargetCell.Offset(-1, 0) = "" Then
MsgBox "You must pick a contiguous cell. No blank spaces allowed!"
GoTo GetTargetCell
End If
If TargetCell <> "" Then
'Do stuff to populate rows or shift data around
Else
'If they picked a blank cell, you can insert new data
TargetCell.Value = NewName
End If
End Sub
Thanks!! I'd been too liberal with the 'Range'. Code is now:
Dim rActive As Range
Dim FirstRow As Integer
Dim LastRow As Integer
Set rActive = ActiveCell
Application.ScreenUpdating = False
FirstRow = Range("C6").Value
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
With Range(FirstRow & ":" & LastRow)
.Copy
With .Offset(1, 0)
.PasteSpecial xlPasteAll
On Error Resume Next
End With
End With
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
It works perfectly! Just need to do the rest of it now...
Objective:
There is data stored in sheet "Risk Partner Data" in a table called "RPdata". In the table there is a column called "AICOW" which bears two results, yes or no.
In a second sheet called "Calc Data", I would like to build a macro that starts at after the last filled cell (but ignores a cell that is empty in between data), and for every row that has a "yes" result in AICOW, it copies into row A the corresponding [RPdata#Parish].
The result I am after is that at the end of Column A, the macro will add the parish name for only the parishes with AICOW (yes) and not any others.
I have attempted but my code is not working and I'm not sure its even right
Set Source = Sheet("Risk Partner Data")
Set c.FormulaR1C1 = _
"=if("RPdata[#[AICOW]]"=""Yes"","Yes",0)
Set Target = [RPdata#Parish]
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.For each c in source.range(RPdata[#AICOW])
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(a)
a = a + 1
End If
End c
Instead of looping, consider filtering and copying the visible cells from the "Parish" column in one go.
Also, consider using the built-in ListObject and ListColumn objects.
Sub CopyParishes()
Dim riskPartnerDataTbl As ListObject
Dim parishCol As ListColumn, AICOWcol As ListColumn
Dim copyRng As Range
Set riskPartnerDataTbl = ThisWorkbook.Worksheets("Risk Partner Data").ListObjects("RPdata")
With riskPartnerDataTbl
Set parishCol = .ListColumns("Parish")
Set AICOWcol = .ListColumns("AICOW")
.Range.AutoFilter Field:=AICOWcol.Index, Criteria1:="Yes"
End With
On Error Resume Next
Set copyRng = parishCol.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not copyRng Is Nothing Then
copyRng.Copy
With ThisWorkbook.Worksheets("Calc Data")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End If
riskPartnerDataTbl.Range.AutoFilter Field:=AICOWcol.Index
End Sub
Please see below code I have found on the internet, which is currently working to a certain degree for me.
Could someone possibly commentate on what each line of this code means so I can understand what its doing?
Im trying to understand it with little programming knowledge and add additional code to look for additional values to paste into additional sheets.
I'm also trying to work out how to make them paste to certain rows one after the other and not maintain the row they were originally in on sheet 1.
Code:
Sub Test()
Dim rw As Long, Cell As Range
For Each Cell In Sheets(1).Range("H:H")
rw = Cell.Row
If Cell.Value = "Dept 1" Then
Cell.EntireRow.Copy
Sheets("Sheet2").Range("A" & rw).PasteSpecial xlPasteValues
End If
Next
End Sub
--
Many thanks
I've added comments as requested. To paste them onto the same row, look at removing the rw variable and replacing it with something that increments by one each time
Sub Test()
'declare variables
Dim rw As Long, Cell As Range
'loop through each cell the whole of column H in the first worksheet in the active workbook
For Each Cell In Sheets(1).Range("H:H")
'set rw variable equal to the row number of the Cell variable, which changes with each iteration of the For loop above
rw = Cell.Row
'check if the value of Cell variable equals Dept 1
If Cell.Value = "Dept 1" Then
'copy the entire row if above is true
Cell.EntireRow.Copy
'paste to the same row of Sheet 2
Sheets("Sheet2").Range("A" & rw).PasteSpecial xlPasteValues
End If
Next
End Sub
Here is your Code Commented hope you understand:
Sub Test()
' Variables Defined as follows:
Dim rw As Long, Cell As Range
' Loop Searching each Cell of (Range H1 to end of last H on sheet1
For Each Cell In Sheets(1).Range("H:H")
' now determine current row number:
rw = Cell.Row
' Test cell value if it contain >> Dept 1 as value:
If Cell.Value = "Dept 1" Then
' Select that row and copy it:
Cell.EntireRow.Copy
' now paste the values of that row into A column and rw row on sheet2:
Sheets("Sheet2").Range("A" & rw).PasteSpecial xlPasteValues
' You should add following to:
' Disable marching ants around copied range:
Application.CutCopyMode = False
End If
Next
End Sub
I have some code that will go through my sheet and find every cell in column A that has the value "Item". Then, it will copy the entire row directly beneath the cell that has the value "Item."
What I'd like to do is this:
Go through the sheet and find each instance of "Invoice," "Invoice Date," and "City"
When those cells are found, copy those cells and the cells immediately to their right
Then go through and find every cell in column A that has the value "Item", and paste (with transpose) the two copied cells at the next blank column of that row.
Then I'll copy the row beneath "Item" with the code I've already written below
Here is the code I have so far, along with a few pictures of what I'd like to do.
Please bear with me as I just started learning VBA yesterday and I'm very new. I know how to do some smaller parts of this, but the whole process is still hazy to me. Any advice appreciated. Thanks!
' Copy rows from one workbook to another at each instance of "Item"
Dim fromBook As Workbook
Dim toBook As Workbook
Application.ScreenUpdating = False
Set fromBook = Workbooks("from.xlsm")
Set toBook = Workbooks("to.xlsm")
Dim i As Range
For Each i In fromBook.Sheets("Sheet1").Range("A1:A1000")
Select Case i.Value
Case "Item"
toBook.Sheets("Sheet2").Range("A" & toBook.Sheets("Sheet2").Rows.Count).End(xlUp).Offset(1, 0).EntireRow.Value = i.Offset(1, 0).EntireRow.Value
Case Else
'do nothing
End Select
Next i
Application.ScreenUpdating = True
Before:
After:
Another After Option, if this is simpler:
Just how I would do it (it may be not that obvious, but should be fast):
Sub Macro1()
Dim mainTab As Range, i As Byte, pstRng As Range, pstChk As Range
With Workbooks("from.xlsm").Sheets("Sheet1") 'get first "Item"-range
Set mainTab = .Columns(1).Find("Item", .Cells(1, 1), xlValues, 1)
Set mainTab = .Cells(mainTab.Row, .Columns.Count).End(xlToLeft).Offset(, 1)
For i = 0 To 2 'build the first table
.Cells.Find(Array("Invoice", "Invoice Date", "City")(i), .Cells(1, 1), xlValues, 1).Resize(1, 2).Copy
mainTab.Offset(0, i).PasteSpecial , , , True
Next
Set pstRng = mainTab
Set mainTab = mainTab.Resize(2, 3) 'the table we will copy later on
Set pstChk = .Columns(1).Find("Item", , xlValues, 1) 'just to check if the next "Item" is a new one
While Intersect(pstChk, .Columns(1).FindNext(pstChk.Areas(pstChk.Areas.Count))) Is Nothing 'add all "Item"-Ranges
Set pstRng = Union(pstRng, .Cells(Columns(1).FindNext(pstChk.Areas(pstChk.Areas.Count)).Row, .Columns.Count).End(xlToLeft).Offset(, 1))
Set pstChk = Union(pstChk, .Columns(1).FindNext(pstChk.Areas(pstChk.Areas.Count)))
Wend
mainTab.Copy pstRng 'copy the first table to all "Item"-Ranges in one step
End With
'Copy rows from one workbook to another at each instance of "Item" by "recycling"
With Workbooks("to.xlsm").Sheets("Sheet2")
pstChk.Offset(1).EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
End Sub
The last part, would replace your initial macro completely.
If any questions pop up, just ask ;)
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim wks As Worksheet
On Error GoTo Err_Execute
For Each wks In Worksheets
ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
Set wksCopyTo = ActiveSheet
wks.Rows(3).EntireRow.Copy wksCopyTo.Rows(3)
'Start search in row 4
LSearchRow = 4
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 4
While Len(wks.Range("A" & CStr(LSearchRow)).Value) > 0
'If value in column E = "Mail Box", copy entire row to Sheet2
If wks.Range("AB" & CStr(LSearchRow)).Value = "Yes" And wks.Range("AK" & CStr(LSearchRow)).Value = "Yes" And wks.Range("BB" & CStr(LSearchRow)).Value = "Y" Then
'Select row in Sheet1 to copy
wks.Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
MsgBox "Copying Row"
'Paste row into Sheet2 in next row
wksCopyTo.Select
wksCopyTo.Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
wksCopyTo.Paste
MsgBox "Pasting Row"
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
wks.Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Next wks
Exit Sub
Err_Execute:
MsgBox "An error occurred."
Hi
I have the above code which based upon from code given elsewhere. The code has been adapted where I need it to do to create a new worksheet for each existing worksheet when copying those rows that meet the criteria given in the if statement. The problem I have are:
Does excel allow you to find out first all the worksheets that exist before running the code so you don't go round in a loop?
The code I have given whilst working on one worksheet, will not execute after the while, and I cannot see why?
When I have run it on the one worksheet it crashes after 32,000 rows
Can anyone help?
I'll answer your questions one by one:
Yes. You can use something like ThisWorkbook.Worksheets.Count to return the number of worksheets the current workbook has. The best way to loop through worksheets however is to itterate through the Worksheets Collection:
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
'Do something
'...
Next wks
Set wks = Nothing
You are never exiting the loop (if you have >32,000 rows of data in Column A), until of course you get an Overflow error (Integers can only go to 32,767 +/-).
See point 2. You are looping beyond the limits of an Integer. Either change the data type to a Long and/or, as stated in point 2, exit your loop at some point.