I require a macro to select all valid data, copy and paste it into a new sheet and save the sheet. he issue is that there may be no data in a sheet as this will be run for 50+ sheets
I have the below but if there is no data then it selects 1mio+ empty rows.
Sub InvoiceBackup()
Sheets("ASM001").Select
Range("A5").Select
Range( _
ActiveCell.End(xlDown).Offset(0, 14), _
ActiveCell.Offset(1, 0)).Select
End Sub
Please help?
In my code I test whether the cell under the header is empy as such
Sub InvoiceBackup()
Dim wksht As Worksheet
Dim rng As Range
Set wksht = Sheets("ASM001")
Set rng = wksht.Range("A5")
If Not IsEmpty(rng.Offset(1, 0)) Then
Set rng = Range(rng.End(xlDown).Offset(0, 14), rng.Offset(1, 0))
End If
End Sub
I know lots of people who search up from the bottom of the sheet for the last nonempty cell. My personal opinion on this is that it is too dependant on the version of Excel for me to be comfortable with it. If another user has a version with a different final row number, that could break your code.
Try something like this in the beginning of the macro:
Range("A1048576").End(xlUp).Select
If ActiveCell.Row = 5 Then Exit Sub 'because there are no data...
Related
I am trying to copy some filtered records to a new sheet in the same excel. But, its just copying the header and not the records. Please suggest. I have defined nc_it_an_sub as the count of records displayed after putting auto filter.
Workbooks("WB1.xlsx").Worksheets("Sheet1").Range("A2:N" & nc_it_an_sub).Select
Selection.Copy
Workbooks("WB1.xlsx").Worksheets("Temp Sheet").Range("A1").PasteSpecial Paste:=xlPasteValues
Try like this:
nc_it_an_sub = 10
Workbooks("WB1.xlsx").Worksheets("Sheet1").Range("A2:N" & nc_it_an_sub).Select
Selection.Copy
Workbooks("WB1.xlsx").Worksheets("Temp Sheet").Range("A1").PasteSpecial _
Paste:=xlPasteValues
If it works, then in your case nc_it_an_sub is getting value of 1 and this should be fixed.
In general, you do not need to use Select in order to Copy a range:
Workbooks("WB1.xlsx").Worksheets("Sheet1").Range("A2:N" & nc_it_an_sub).Copy
Workbooks("WB1.xlsx").Worksheets("Temp Sheet").Range("A1").PasteSpecial _
Paste:=xlPasteValues
or even as a 1-liner:
Worksheets("Source").Columns("A:D").Copy Destination:=Worksheets("Target").Range("a1")
You could copy just the visible cells.
As an example add this code to a Worksheet module.
This piece of code isn't essential - it creates a filter when you double-click a cell.
It filters the current region down to the value you double-clicked.
Private rCellClicked As Range
'Code to create a filtered range.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With ActiveSheet
If .FilterMode Then
.ShowAllData
rCellClicked.Select
Else
With Target
.CurrentRegion.AutoFilter Field:=.Column - .CurrentRegion.Column + 1, Criteria1:=.Value
End With
Set rCellClicked = Target
'This procedure will copy the cells to a new sheet.
CopyFiltered Target.CurrentRegion
End If
End With
End Sub
This procedure copies the visible cells in your filtered list (including headings) to a range A1 in a new sheet:
Public Sub CopyFiltered(FilteredRange As Range)
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets.Add
FilteredRange.SpecialCells(xlCellTypeVisible).Copy Destination:=wrkSht.Range("A1")
End Sub
SOLVED, SEE CODE BELOW
I'm working on a code for filtering data and pasting the filtered data to the "destination" sheet.
In the "review" sheet there is a long list with data that can be subdivided in certain categories. In cell F9 off the coversheet I can select a category.
After pressing a button the data in the "review" sheet needs to be filtered and the data that is left after filtering should be pasted in the "destination" sheet. the "destination" sheet is a blank new sheet.
The filtering part works, however the copy paste part is giving some errors. Because the "review" sheet has some merged cells in it. I am able to paste the formatting and the columnwidths, but the values give an error due to merged cells. Is there some way to work around this??
In addition to this, when pasting the formatting, this is pasted to the same number of rows as in the "review" sheet before filtering. I want the formatting to be applicable on only the numer of rows left after filtering.
I hope someone can help me out.
See my source code below:
Dim wksCVP As Worksheet
Dim wksReview As Worksheet
Dim wksNew As Worksheet
Set wksReview = Worksheets("REVIEW")
Set wksCVP = Worksheets("COVER PAGE")
Set wksNew = ThisWorkbook.Worksheets.Add
wksReview.Cells.Copy wksNew.Cells
wksNew.Cells.UnMerge
Dim LastRow As Long
With wksNew
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Select Case wksCVP.Range("F9").Value
Case "Instrumentation"
kolom = "J"
Case "Equipment"
kolom = "K"
Case "Design / Fabrication"
kolom = "L"
Case "Inspection & Testing"
kolom = "M"
Case "General / Other"
kolom = "N"
End Select
If wksCVP.Range("F9").Value <> "" Then
For i = 5 To LastRow
If wksNew.Range(kolom & i).Value <> "X" Then
wksNew.Rows(i).EntireRow.Hidden = True
End If
Next i
End If
wksNew.Activate
ActiveSheet.Range("A5", "Z" & LastRow + 1).SpecialCells(xlCellTypeVisible).Copy
With Sheets("DESTINATION").Range("A1")
.PasteSpecial Paste:=xlPasteAll
End With
wksNew.delete
For the Formats and the ColumnWidths being in a merged cell, which is only partially copied, the easiest way is to add a new worksheet, to copy the initial values there and to unmerge it. Then do something like this:
Option Explicit
Sub TestMe()
Dim wksTheNew As Worksheet
Dim wksReview As Worksheet
Dim wksDestination As Worksheet
Set wksReview = Worksheets("Review")
Set wksDestination = Worksheets("Destination")
Set wksTheNew = ThisWorkbook.Worksheets.Add
wksReview.Cells.Copy wksTheNew.Cells
wksTheNew.Cells.UnMerge
'now copy the formats and the values from wksTheNew
'it will not give an error, because it is unmerged
Application.DisplayAlerts = False
wksTheNew.Delete
Application.DisplayAlerts = True
End Sub
Once you are ready with your actions, you may simply delete the new worksheet.
Just change your sequence:
With Sheets("DESTINATION").Range("A1")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
Pasting values first shouldn't trigger an error.
I am not a Dev, but given I do use Excel, I have been tasked to create a looping macro that will check for a string ('Resource') in a cell and if it finds that string, then run a Copy and Paste code and then move to the next row. This starts at row 5 and runs continuously until row 199, but does not work on every row, hence the validation for the string Resource.
I have managed to create the macro for the Copy and Paste but it also has issues as I created it using the macro recorder and it only works on the row I actually did the recording on.
I am at a complete loss, can anyone help?
this is what I have so far
A New Resource name is added manually to the spreadsheet
the user clicks cell (C6) to focus the curser
the user clicks a macro button called 'Forecast for Future Project 1' to start the macro
On the button click the Macro will:
Interogate if cell to the left of current cell (B6) = 'Resource'
IF Yes, THEN
Sub CP()
DO
Range("C6").Select
Selection.Copy
Application.Goto Reference:="ProjAdd"
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=SUMIF('Current Project Utilisation'!R2C1:R62C1,RC1,'Current Project Utilisation'!R2C:R62C)+SUMIF('Future Project 1'!R2C1:R62C1,RC1,'Future Project 1'!R2C:R62C)"
Range("ProjAdd").Select
Selection.Copy
Range("C6").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.Paste
Range("B6").Select
Loop Until ActiveCell.Address(0,0) = "$B$199"
End Sub
Move to cell under original active cell (C7) and Repeat the Macro until cell C199 is reached
If (B6) does not = 'Resource' then move to go to the cell under (C7) aand Repeat the Macro until cell C199 is reached
Refresh Worksheet to update data
Would something like this work for you?
Sub CopyPasteResource()
Dim CopyRange As Range
Dim Cell As Range
Set CopyRange = Workbooks("YourWorkBookName").Sheets("Sheet1").Range("C6:C199")
For Each Cell In CopyRange
If InStr(1, Cell.Offset(0, -1).Text, "Resource") Then
Cell.Copy
'paste where you wish
End If
Next Cell
End Sub
EDIT: Or do you want to loop through B6:B199 and then C6:199? I'm not entirely clear on the aim.
Ah the old macro recorder, generating 90% extra code since 1997. I couldn't exactly figure out from your question what exactly is being copied and to where but this code will loop through rows 5 to 199, check if the value in column B = "Resource" and then set the corresponding value in column C, you should be able to modify for your needs but I think you definitely want a structure more like this than what the recorder generated for you..
public sub cp()
Dim ws as Worksheet
Set ws = Worksheets("Current Project Utilisation")
Dim i as int
for iI = 5 to 199
if(ws.cells(i, 2).value = "Resource") then
ws.cells(i, 3).value = "what you're copying"
end if
next I
end sub
Assuming your cell range doesn't change you can do this for the looping part
Sub ResourceCheck()
Dim WS As Worksheet
Set WS = ActiveSheet
Dim Resources() As Long, r As Long
ReDim Resources(5 To 199)
For r = 5 To 199
If UCase(WS.Cells(r, 2).Value) = "RESOURCE" Then
WS.Cells(r, 3).Value = "x"
'Do copy paste part
End If
Next r
Application.Calculate
End Sub
Can you add a sample of your data? It's a bit hard to see what you're referencing to and how the data relates to each other.
Also, where is the "Projadd" cell reference? And what does it do?
Sub CP()
' I like to know what worksheet I'm on
Dim ws as Worksheet
' if it's a dedicated worksheet use this
' Set ws = ThisWorkbook.Worksheets("Sheet1")
' Otherwise following your current code
Set ws = ActiveSheet
' I also like to grab all my data at once
Dim Data as Variant
Data = ws.Range("B6:B199")
' No need to focus the cursor
For row = 5 to 199
' No need to select any range
' Is this case-sensitive???
If Data(row-4, 1) = "Resource" Then
' Copy C6??? Paste 'ProjAdd'
ws.Cells(row, 3).Copy Range("ProjAdd")
Application.CutCopyMode = False
End If
Next
End Sub
I have a column A with data up to A300.
In this range, some of theses cells are empty, some contain values.
In VBA, I set the formula of the cell A1 then I use the autofill function to set it all over my column (up to A300) like this :
ws.Range("A1").Select
Selection.AutoFill Destination:=ws.Range(ws.Cells(1, 1), ws.Cells(300, 1))
My problem is that datas contain on some cells are erased too ! I'm trying to autofill like it but only throught the empties cells.
I tried to add a filter on my worksheet like this :
ws.Range("$A$1:$A$300").AutoFilter Field:=1, Criteria1:="="
Then I reused the autofill function, but it seems to fill thourght the filtered cells...
Can't we add a parameter like "only empties cells" to the autofill function ? Something like this :
Selection.AutoFill Destination:=ws.Range(ws.Cells(1, 1), ws.Cells(300, 1)), Criteria1:="="
Thanks for your replies !
with data like:
I would do a single copy rather than a fill-down:
Sub luxation()
Range("A1").Formula = "=ROW()"
Dim rDest As Range
Set rDest = Intersect(ActiveSheet.UsedRange, Range("A1:A300").Cells.SpecialCells(xlCellTypeBlanks))
Range("A1").Copy rDest
End Sub
with this result:
NOTE:
The formulas adjust after being copied.
EDIT#1:
Please note that there are some circumstances under which this code will not work. It is possible that UsedRange my not extend down to cell A300.
For example, if the worksheet is totally empty except for a formula in A1 and some value in A3. In this case Rdest will only include the single cell A2. The code will leave A4 through A300 untouched.
Assuming you want static values, I would use a loop. The one below will fill all empty cells with poop:
Sub AllFillerNoKiller()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
For Each c In ws.Range("A1:A300")
If c.Value = "" Then c.Value = "poop"
Next
End Sub
Apologies, I miss-understood you question - Want to fill all blank cells with the value in A1? - here you go:
Sub Replace()
If Trim(Range("A1").Value) = "" Then
MsgBox "There's no value in A1 to copy so there's nothing to copy to all blank cells", vbInformation, "Nothing in A1"
Exit Sub
Else
Range("A1:A300").SpecialCells(xlCellTypeBlanks).Select
Selection.Value = Range("A1").Value
End If
End Sub
You can also use below code:
stAddress = Sheet1.Range("A1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Address
Sheet1.Range(st).Value = "Empty"
I've looked around the forum and played with various options but not found a clear match for my problem:
My task is to copy data from a worksheet (called “workorders”) to a second worksheet (called “Assignments”). The data to be copied is from the “workorders” worksheet starting at cell range “E2, P2:S2”; and also copied from each row (same range) until column “P” is empty – (the number of rows to be copied can vary each time we need to run this macro so we can’t select a standard range) . Then pasted into the “Assignments” worksheet, starting at cell “A4”. I’ve used the forum so far to successfully copy a single row of date (from row 2) – I admit that’s the easy part, and I’ve used various versions of code to achieve this.
I’ve also tried some code (which I found via watching a youtube clip and modifying http://www.youtube.com/watch?v=PyNWL0DXXtQ )to allow me to run a loop which repeats the copy process for each required row in the “workorders” worksheet and then pastes the data into the “assignments” worksheet- but this is where I am not getting it right, I think I’m along the right lines and think I’m not far off but any help would be very useful.
Code examples below (first 2 only copy first row, 3rd example is where I’ve tried to loop and copy multiple rows:
Sub CopyTest1()
' CopyTest1 Macro
'copy data from workorders sheet
'Worksheets("workorders").Range("E2,P2,Q2,R2,S2").Copy
Worksheets("workorders").Range("E2, P2:S2").Copy
'paste data to assignments sheet
'sheets("assigments dc").Range("A4").Paste
Sheets("Assigments DC").Select
Range("A4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Sub CopyTest2()
Sheets("workorders").Range("e2,p2,q2,r2,s2").Copy Sheets("assigments dc").Range("a4")
End Sub
Sub CopyTest3()
Dim xrow As Long
'Dim xrow As String
xrow = 2
Worksheets("workorders").Select
Dim lastrow As Long
lastrow = Cells(Rows.Count, 16).End(xlUp).Row
Do Until xrow = lastrow + 1
ActiveSheet.Cells(xrow, 16).Select
If ActiveCell.Text = Not Null Then
'Range("E2,P2,Q2,R2,S2").Copy
'Selection = Range("E2,P2,Q2,R2,S2").Copy
'Cells(xrow, 5).Copy
Cells(xrow, 5).Copy
Sheets("Assigments DC").Select
Range("A4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("workorders").Select
End If
xrow = xrow + 1
Loop
End Sub
Try this:
Sub LoopCopy()
Dim shWO As Worksheet, shAss As Worksheet
Dim WOLastRow As Long, Iter As Long
Dim RngToCopy As Range, RngToPaste As Range
With ThisWorkbook
Set shWO = .Sheets("Workorders") 'Modify as necessary.
Set shAss = .Sheets("Assignments") 'Modify as necessary.
End With
'Get the row index of the last populated row in column P.
'Change accordingly if you want to use another column as basis.
'Two versions of getting the last row are provided.
WOLastRow = shWO.Range("P2").End(xlDown).Row
'WOLastRow = shWO.Range("P" & Rows.Count).End(xlUp).Row
For Iter = 2 to WOLastRow
Set RngToPaste = shAss.Range("A" & (Iter + 2))
With shWO
Set RngToCopy = Union(.Range("E" & Iter), .Range("P" & Iter & ":S" & Iter))
RngToCopy.Copy RngToPaste
End With
Next Iter
End Sub
Read the comments first and test.
Let us know if this helps.
From what I see, you are only copying the cell in Column E. You could correct this by replacing Cells(xrow, 5).Copy with
Union(Sheets("workorders").Cells(xrow,5),Sheets("workorders").Range(Cells(xrow,"P"),Cells(xrow,"S")).Copy
However, using Select and Copy are not ideal. Instead, you can assign the value of the range directly:
Sheets("Assignments DC").Range("A4").Value = Union(Sheets("workorders").Cells(xrow,5),Sheets("workorders").Range(Cells(xrow,"P"),Cells(xrow,"S")).Value
More info on the Union method and why using Select is bad.
Is it even possible to run a line like this?
Worksheets("workorders").Range("E2, P2:S2").Copy
Each time I try different ways to copy/select a range which contains in my case, A3 and the range A34:C40 ("A3, A34:C40").Copy i get an error saying theres to many parameters.. Could this be because I'm running excel 2007?
Any tips or help would be greatly apreciated! :)