Excel: how to paste to first blank cell? - excel

I'm trying to paste info to the first blank cell in colum A of a sheet? How can I do this?
This is what I have done but it paste the info 1000 times. What do I need to change?
Thanks in advance.
Range("B2:E2").Select 'Selet info to copy
Selection.Copy 'Copy
Sheets(Range("A2").Value).Select 'Goto Sheet Listed in cell A2
Dim i 'define i
For i = 3 To 1000 'Set up loop size
If Range("A" & CStr(i)).Value = "" Then 'If Cell Ai is blank
Range("A" & i).Select
ActiveSheet.Paste 'Paste info
End If
Next i
End If

While modifying the loop with an Exit For will work, there is a much better approach - finding the last cell in a column can be achieved with
Set lastCell = Range("A1").End(xlDown)
set freeCell = lastCell.Offset(1,0)
This assumes that there is at least one cell below A1. If you know (as in your example) that there will never be more than 1000 rows occupied, you can do this in the other direction:
Function freeCell(r As Range) As Range
' returns first free cell below r
Dim lc As Range ' last used cell on sheet
Set lc = r.Offset(1000, 0).End(xlUp).Offset(1, 0)
Set freeCell = lc
End Function
Sub testIt()
Dim p As Range
Set p = freeCell(Range("A3"))
MsgBox "the address of p is " & p.Address
End Sub
The function freeCell returns the cell you are after; the sub testIt shows that it works (and how it is called). In your case, you can greatly simplify your code to
Sub doIt()
Dim sh As Worksheet, tCell As Range
Sheets("Sheet1").Range("B2:E2").Copy
Set sh = Sheets(Range("A2").Value)
Set tCell = freeCell(sh.Range("A3"))
sh.Paste tCell
End Sub
Note - when you record a macro, you get lots of Activate, Select etc commands sneaking in. These can usually be avoided - and there are plenty of excellent articles online (and on this site) explaining why you would want to avoid them. The above snipped shows how to copy from one sheet to another without any of these.
If you are never sure that there is anything on your target sheet (no header row in row 2, for example) you could modify your code so the target cell is never above row 3:
If tCell.Row < 3 Then Set tCell = tCell.Offset(3 - tCell.Row)

Your FOR LOOP will run from cell A3 until A1000 and for every empty cell it will paste the value. You want to exit your loop as soon as the condition is matched. You want to add an Exit For condition.
If Range("A" & CStr(i)).Value = "" Then
Range("A" & i).Select
ActiveSheet.Paste
Exit For
End If
Source

Related

Loop through list and run code for every item (VBA)

I have a list of names, and some code that I would like to run for every single name.
What I'm starting with is this:
Dim cell As Range
For Each cell In Worksheets("Reference").Range("b2:b237")
[rest of my code here]
Next cell
The issue is, what I'm actually trying to do is:
Step 1) Select a name from a drop down list in cell A1
Step 2) There are a bunch of other cells with formulas that reference A1
Step 3) Run code
Step 4) Select next name from drop down list in A1, repeat Steps 2 & 3, until end of list.
Edit: I found something on an old thread that seems to work for what I'm doing:
Sub Macro1()
Sheets("Sheet2").Activate
Range("A1").Select
Do While True
If Selection.Value = "" Then
Exit Do
Else
Selection.Copy
Sheets("Sheet1").Activate
Range("A1").Activate
ActiveSheet.Paste
[rest of my code]
Sheets("Sheet2").Activate
Selection.Offset(1, 0).Select
End If
Loop
End Sub
This should do the job, but if anyone has a more efficient way rather than copying and pasting each value from the list to the cell, that would be very helpful too!
Thank you.
This will take each name in a range and put it into a cell sequentially - you will need to edit to put your sheetnames and ranges in
Sub LoopThroughNames()
dim RangeWithNames as range
'define list of names - needs editing
set RangeWithNames = Worksheets("othersheetname").Range("range with names")
dim TargetCell as range
set TargetCell = worksheets("Sheet with calcs").Range("A1") 'top sheet, cell A1 edit as needed
dim r as range
for each r in RangeWithNames
targetcell= r 'assign name into A1
'do your stuff
next r
End Sub

Copy paste a fixed row based on some condition else skip to next column in that row

Have data set in I11:X11 and I want to copy formulas seating I12:I12 into I13:X20 based on data contained in I11:X11.
Starting with I11, if that contains certain value lets say TEST, then want to increment row for that range to next column that is J11 and if J11 <> TEST, then copy J12:X12 to J13:X20.
Further want to skip pasting this entire logic based on flag seating in column H13:H20, for example if H13 = Y, then skip to next row.
Adding a screenshot to further explaining the issue.
Condition should start with first member in range I11:X11, if it encounters first member <> TEST till T11 , then it should start copying from that range. In this case it encountered first <> TEST member at L11, then it should copy from L12:T12 to L13:T24 and V12:X12 to V13:X13. Further this logic should work on the flag contained in column H. If this column H Contains Y,then above logic should not paste in that row, this pasting activity should go on until last value in column H starting from H13.
The condition value from I11:T11 can change between TEST and any other values, not further.
Want to achieve this on a button click using a VBA code.
Adding Code, but it limits to the fixed column H values and Fixed row values.
Sub CopyOnCondition1()
Dim sh1 As Worksheet, c As Range
Set sh1 = Worksheets("SheetNameHere") 'change the sheetname
For Each cel In sh1.Range("I11:T11")
If Not cel.Value = "TEST" Then
sh1.Range(Cells(12, cel.Column), Cells(12, 20)).Copy
sh1.Range(Cells(13, cel.Column), Cells(24, 20)).PasteSpecial xlPasteFormulas
End If
Next
For Each cel In sh1.Range("H13:H24")
If cel.Value = "Y" Then sh1.Range("I" & cel.row & ":T" & cel.row).ClearContents
Next
End Sub
enter image description here
As I could understand from the Question I think you are looking for something like this:
Sub CopyOnCondition1()
Dim sh1 As Worksheet, c As Range
Set sh1 = Worksheets("SheetNameHere") 'change the sheetname
For Each cel In sh1.Range("I11:T11")
If Not cel.Value = "TEST" Then
sh1.Range(Cells(12, cel.Column), Cells(12, 20)).Copy
sh1.Range(Cells(13, cel.Column), Cells(24, 20)).PasteSpecial xlPasteFormulas
End If
Next
For Each cel In sh1.Range("H13:H24")
If cel.Value = "Y" Then sh1.Range("I" & cel.row & ":T" & cel.row).ClearContents
Next
End Sub
First It will paste in the complete Range. Then it wo go and check if H have Y, if yes, then it will delete the formula from that row.

Copy and paste data by date - excel vba

I need to move data from one sheet to another by the criteria date, but the selection that I made using IF only select the last cell that matches that criteria.
Here is what i got so far:
Sub Copiar()
Dim range1 As Range
Set range1 = Range("k56:k58")
For Each cell In range1
If cell.Value = Range("R55").Value Then
cell.Offset(0, 2).Select
Selection.Copy
Sheets("Plan2").Activate
Range("r56").Select
ActiveSheet.Paste
End If
Next
End Sub
You are finding them all, the problem is that every answer overwrites R56 on the other sheet. Here's code that advances that destination cell every repeat of the loop - and also avoids the bad practice of selecting and activating every sheet and cell you are working with:
Sub Copiar()
Dim range1 As Range, destin as Range
Set range1 = Range("k56:k58")
Set destin= Sheets("Plan2").Range("r56")
For Each cell In range1
If cell.Value = Range("R55").Value Then
cell.Offset(0, 2).copy destin
set destin=destin.offset(1,0) ' Crucial bit here
End If
Next
End Sub
I'm assuming you don't want to overwrite Sheets("Plan2").Range("r56") each time you find the value.
If that's the case, this code writes the found value into the same row it is found on the first sheet.
This works without copy paste and selecting or activating cells / sheets.
Also if you specify your sheet with the source data, like i did, it doesn't even matter which sheet you start the macro from.
Sub Copiar()
Dim range1 As Range
Set range1 = Sheets(1).Range("K56:K58")
For Each cell In range1
If cell.Value = Sheets(1).Range("R55").Value Then
Sheets("Plan2").Range("R" & cell.Row).Value = cell.Offset(0, 2).Value
End If
Next
End Sub

Understanding & Additional code for excel row copy based on value

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

copy data based on criteria to another sheet and clear the contents

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:

Resources