I have a constant task at work where I need to copy a list of numbers to another sheet. In that sheet, I need to paste those numbers one by one, in a cell to the right of cells with a certain value(that repeats in a column). (notice that the target table is sorted by that value -"מודל תגובה" and there are hidden rows.
It's hard to explain so I hope the images will do.
I tried to write suitable code but I kept getting different errors.
It seems that problems occur when copying the cell values to the target cells.
Dim i As Integer
i = 4
Do While IsEmpty(Cells(i, 1).Value) = False
Worksheets(1).Select
Cells(i, 1).Copy
Worksheets(2).Select
Cells.Find(What:="מודל תגובה", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Activate
If IsEmpty(ActiveCell.Value) = False Then
Selection.FindNext(After:=ActiveCell).Activate
ActiveCell.Offset(0, -1).Paste
Else
ActiveCell.Offset(0, -1).Select
ActiveCell.Paste
End If
i = i + 1
Loop
sorry for the shitty code(literally my first macro).
The solution would be to loop through the visible cells of the filtered range only.
Make sure the destination is filtered for "מודל תגובה" before running this code. It needs to look like your second image before running this code.
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets(1)
Dim DestinationSheet As Worksheet
Set DestinationSheet = Worksheets(2)
Dim LastRow As Long
LastRow = DestinationSheet.Cells(DestinationSheet.Rows.Count, "B").End(xlUp).Row
Dim VisibleCells As Range
On Error Resume Next 'next line errors if no visible cells so we turn error reporting off
Set VisibleCells = DestinationSheet.Range("A2", "A" & LastRow).SpecialCells(xlCellTypeVisible)
On Error Goto 0 'turn error reporting on or you won't see if other errors occur
If VisibleCells Is Nothing Then 'abort if no cells are visible in the filter
MsgBox "No cells to paste at"
Exit Sub
End If
Dim SourceRow As Long
SourceRow = 4 'start row in your source sheet
Dim Cell As Range
For Each Cell In VisibleCells.Cells 'loop through visible cells
Cell.Value = SourceSheet.Cells(SourceRow, "A").Value 'copy value
SourceRow = SourceRow + 1 'incerease source row
Next Cell
Make sure to define DestinationSheet and SourceSheet with your sheets names.
Try this:
Dim i As Integer
Dim Last_Row as Long
Worksheets(1).Select
'The "1" Of the line below means that the variable gonna count the rows of the first column (A)
Last_Row = Application.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:A" & Last_Row).Copy
Worksheets(2).Select
Range("A1").Select
ActiveSheet.Paste
Related
I have two sheets (sheet 1 and sheet 2). Sheet1 is a subset of sheet2. I have written a macro that compares the headers of two sheets and then if matches, copy all the contents from Sheet 1 to sheet 2.
The next requirement is, I have a key column in Sheet1, I now need to paste the contents of sheet 1 to sheet 2, sheet3, sheet 4 based on the key column values.
Please find attached the screenshot for details and also please find the code which I have written by taking the help of you guys in the Stack-overflow.
I am new to this and need your help. Image.Please Click
Code:
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim lastrow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS , desWS1 As Worksheet
Set srcWS = Sheets("Sheet1")
Set desWS1 = Sheets("Sheet2")
lastrow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = desWS1.Cells(1, Columns.count).End(xlToLeft).Column
For Each header In desWS1.Range(desWS1.Cells(1, 1), desWS1.Cells(1, lCol))
Set foundHeader = srcWS.Rows(2).Find(header, LookIn:=xlValues, lookat:=xlWhole)
If Not foundHeader Is Nothing Then
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(lastrow, foundHeader.Column)).Copy desWS1.Cells(1, header.Column)
End If
Next header
lCol = desWS2.Cells(1, Columns.count).End(xlToLeft).Column
**' I am stuck here. Unable to think beyond these two lines after applying the filter**
**Sheets("Sheet1").Cells(1, 1).AutoFilter Field:=7, Criteria1:="Yellow"
Sheets("Sheet1").Cells(1, 1).SpecialCells(xlCellTypeVisible).Select**
For Each header In desWS2.Range(desWS2.Cells(1, 1), desWS2.Cells(1, lCol))
Set foundHeader = srcWS.Rows(2).Find(header, LookIn:=xlValues, lookat:=xlWhole)
If Not foundHeader Is Nothing Then
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(lastrow, foundHeader.Column)).Copy desWS2.Cells(1, header.Column)
End If
Next header
Application.ScreenUpdating = True
End Sub
Many thanks for your time and assistance.
Not my work so won't even pretend, but have you tried this?
Credit: https://www.excelcampus.com/vba/copy-paste-cells-vba-macros/
Sub Range_Copy_Examples()
'Use the Range.Copy method for a simple copy/paste
'The Range.Copy Method - Copy & Paste with 1 line
Range("A1").Copy Range("C1")
Range("A1:A3").Copy Range("D1:D3")
Range("A1:A3").Copy Range("D1")
'Range.Copy to other worksheets
Worksheets("Sheet1").Range("A1").Copy Worksheets("Sheet2").Range("A1")
'Range.Copy to other workbooks
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy _
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1")
End Sub
Sub Paste_Values_Examples()
'Set the cells' values equal to another to paste values
'Set a cell's value equal to another cell's value
Range("C1").Value = Range("A1").Value
Range("D1:D3").Value = Range("A1:A3").Value
'Set values between worksheets
Worksheets("Sheet2").Range("A1").Value = Worksheets("Sheet1").Range("A1").Value
'Set values between workbooks
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").Value = _
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Value
End Sub
Essentially you trying to do a vlookup it sounds like. This site has helped me in the past as well.
https://powerspreadsheets.com/excel-vba-vlookup/
VLookupResult = WorksheetFunction.vlookup(LookupValue, Worksheet.TableArray, ColumnIndex, False)
I have a macro inherited from my coworker who left.
I have a sheet created from a source sheet, consisting of 30000 rows. Including the main data, over a million blank rows are created.
There are no blank rows between. It is 30k+ rows of data without a break.
I made a separate macro that deletes the blank rows after the fact.
I have to run the macro twice.
The first time, the black borders (carried over from the first sheet) are deleted, leaving a million borderless rows.
I run it a second time, which leaves the last used cell.
Sub DeleteUnused()
Dim myLastRow As Long
Dim myLastCol As Long
Dim wks As Worksheet
Dim dummyRng As Range
For Each wks In ActiveWorkbook.Worksheets
With wks
myLastRow = 0
myLastCol = 0
Set dummyRng = .UsedRange
On Error Resume Next
myLastRow = _
.Cells.Find("*", after:=.Cells(1), _
LookIn:=xlFormulas, lookat:=xlWhole, _
searchdirection:=xlPrevious, _
searchorder:=xlByRows).Row
myLastCol = _
.Cells.Find("*", after:=.Cells(1), _
LookIn:=xlFormulas, lookat:=xlWhole, _
searchdirection:=xlPrevious, _
searchorder:=xlByColumns).Column
On Error GoTo 0
If myLastRow * myLastCol = 0 Then
.Columns.Delete
Else
.Range(.Cells(myLastRow + 1, 1), _
.Cells(.Rows.Count, 1)).EntireRow.Delete
.Range(.Cells(1, myLastCol + 1), _
.Cells(1, .Columns.Count)).EntireColumn.Delete
End If
End With
Next wks
End Sub
Here is the macro I use to clean-up all blank rows as well as blank columns.
You can decide if you only want to remove empty rows, and keep empty columns.
Sub Remove_Empty_Rows_And_Columns()
Dim wks As Worksheet
Dim row_rng As Range 'All empty rows will be collected here
Dim col_rng As Range 'All empty columns will be collected here
Dim last_row As Long 'points to the last row in the used range
Dim last_column As Long 'points to the last column in the used range
Dim i As Long 'iterator
Set wks = ActiveSheet
With wks
'finding last row in used range
last_row = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'finding last column
last_column = .UsedRange.Columns(.UsedRange.Columns.Count).Column
'loop through all rows in the used range and
'find if current row is blank or not
For i = 1 To last_row
If Application.WorksheetFunction.CountA(.Rows(i)) = 0 Then
'current row is blank..
If row_rng Is Nothing Then
'this is the first blank row. Lets create a new range for it
Set row_rng = .Rows(i)
Else
'this is not the first. Let's add it to the previous others
Set row_rng = Excel.Union(row_rng, .Rows(i))
End If
End If
Next
'same logic applies for empty rows
For i = 1 To last_column
If Application.WorksheetFunction.CountA(.Columns(i)) = 0 Then
If col_rng Is Nothing Then
Set col_rng = .Columns(i)
Else
Set col_rng = Excel.Union(col_rng, .Columns(i))
End If
End If
Next
End With
'lets check if we managed to find any blank rows
If Not row_rng Is Nothing Then
row_rng.EntireRow.Delete
Else
MsgBox "no rows to delete"
End If
'checking if we found any empty columns
If Not col_rng Is Nothing Then
col_rng.EntireColumn.Delete
Else
MsgBox "no columns to delete"
End If
End Sub
Per my comment this will delete blank rows. Just put this as the last line of the macro that created the blank rows.
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
EDIT: I may have spotted an issue as soon as posting it the myRange
variables dont seem to be doing anything - so I'm feeling they were
there from a method i was using ages ago and there decided to crop out
I'll remove the whole myRange variable and see what happens
Set myRange = ActiveSheet.Range("1:1")
Set myRange = ActiveSheet.Range("A:A")
EDIT 2: Ok so changing the numCols and numRows functions to only use
numCols = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
numRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
They now return the correct row and Column numbers
But now when I run selectBlock() it gives me runtime error 28 "Out of Stack Space"
Hello All, I've been writing code to be able to go through multiple sheets and copy the data across to a master workbook
Im coding this to work on any file depending what you pass to it - which has been fine
What im having problems with is the Functions I have made which find the last populated row for any sheet I pass to it
Sub test()
selectBlock().Select
End Sub
Function selectBlock() As Range
Dim row As Integer: row = numRows() 'Finds last populated row
Dim col As Integer: col = numCols() 'Finds last populated column
Set selectBlock() = Range("A2:" & Cells(row, col).Address)
'sets this area starting from cell A2 as the Range
End Function
Function numCols() As Integer
Dim myRange As Range
Set myRange = ActiveSheet.Range("1:1") 'Checks first row to see how many populated columns there are
numCols = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
End Function
Function numRows() As Integer
Dim myRange As Range
Set myRange = ActiveSheet.Range("A:A") 'Checks first columns to see how many populated rows there are
numRows = Range("A" & Rows.Count).End(xlUp).row
End Function
When I call the test Sub it causes Excel to hang then crash with no error code
So i imagine im creating some kind of loop or critical error that isnt handled by excel very well
Any help with this would be really appreciated
I can also understand if how im going about it is incredibly stupid
I used to code in Java and maybe im using techniques or pitfalls that I never got rid of - Im self taught at VBA like most and so never learnt official coding practices for VBA
Lot of things here
Fully qualify your cells
Use Long and not Integer when working with row and columns
Use error handling. This will avoid the Excel crashing.
Try this
Sub test()
On Error GoTo Whoa
selectBlock().Select
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
Function selectBlock() As Range
Dim row As Long: row = numRows() 'Finds last populated row
Dim col As Long: col = numCols() 'Finds last populated column
Set selectBlock = ActiveSheet.Range("A2:" & ActiveSheet.Cells(row, col).Address)
End Function
Function numCols() As Long
numCols = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
End Function
Function numRows() As Long
numRows = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).row
End Function
Replace
Set selectBlock() = Range("A2:" & Cells(row, col).Address)
to
Set selectBlock = Range("A2:" & Cells(row, col).Address)
it looks recursive :P
There are safer ways to find the LastRow and LastCol, I like the Find function.
See more detailed in my code's comments.
Code
Sub test()
Dim Rng As Range
Set Rng = selectBlock
Rng.Select '<-- Not sure why you need to Select ?
End Sub
'============================================================
Function selectBlock() As Range
Dim LastRow As Long
Dim LastCol As Long
LastRow = FindLastRow(ActiveSheet) 'Finds last populated row
LastCol = FindLastCol(ActiveSheet) 'Finds last populated column
Set selectBlock = Range(Cells(2, "A"), Cells(LastRow, LastCol))
End Function
'============================================================
Function FindLastCol(Sht As Worksheet) As Long
' This Function finds the last col in a worksheet, and returns the column number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastCol = LastCell.Column
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
'============================================================
Function FindLastRow(Sht As Worksheet) As Long
' This Function finds the last row in a worksheet, and returns the row number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastRow = LastCell.row
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
So, after roughly 3 hours or more of searching google and for an answer, I can't seem to find an answer that fits my specific case. I've been grappling with a macro, and finally have it mostly working BUT getting it to copy/paste to a new sheet is vexing me to no ends. Here's the copy/paste lines (also the prior copy/paste that I tried to make work before I gave up on it) :
Sub Filtration()
Application.Goto Sheet1.Range("R1")
Application.ScreenUpdating = False
Dim writeRow As Integer
Dim percentage As Double
'to create skip conditions for row 1 & 2
counter = 1
For Each Cell In Sheets(1).Range("R:R")
'second part of skip condition
If counter > 2 Then
'creates condition to ignore blank cells or cells with a zero or negative number
If Cell.Value = "" Or Cell.Value <= 0 Then
Else
'creates a way to ignore offset cells if =< 0 (might need to add in for blank too)
If Cell.Offset(, -2).Value <= 0 Then
percentage = 0
Else
percentage = Cell.Value / Cell.Offset(, -2).Value
End If
'divide the current cell's value by the the cell one column over's value and compare
If percentage > 0.02 Then
Set Mastersheet = Worksheets("Sheet1") ' Copy From this sheet
Set Pastesheet = Worksheets("Sheet2") ' to this sheet
Cell.EntireRow.Copy ' copy the row from column O that meets that requirements (above, 1 and also win in Q)
'Pastesheet.Cells(lastRow + 1, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
Dim LastRow As Long
With Pastesheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' get last row in column "A
.Cells(LastRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
End With
End If
End If
End If
'final part of skip condition to ignore the two headers - has to be here to work, before next but after the last End IF
counter = counter + 1
Next
Application.ScreenUpdating = True
End Sub
The commented copy/paste just errors out on me on the writeRow part and couldn't figure out why, and searching turned up no reasons either. The second half works but just overwrites the same row over and over, and all the answers and examples I found out there claim it should work, so I'm at a loss. Does anyone have any ideas?
I guess you are after something like the code below (this section of code takes care only for the Paste section):
Dim LastRow As Long
Dim LastCell As Range
With Pastesheet
' safer way to get the last row
Set LastCell = .Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
LastRow = LastCell.Row
End If
.Cells(LastRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
End With
I am New to VBA and i dont know anything in it. So the problem is that i have a excel with dynamic sheets and data. The datas in all the sheets will be in similar format. The number of data in all the sheet will be changing and the sheets to. so could anyone help me with that. I would like be in a great deal of debt to you if you help me out.
Code what i did so for
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
' Find the last row with data on the summary worksheet.
Last = LastRow(DestSh)
' Specify the range to place the data.
Set CopyRng = sh.Range("A1:b60")
' Test to see whether there are enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Rows.count > DestSh.Rows.count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
' This statement copies values and formats from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
' Optional: This statement will copy the sheet
' name in the H column.
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
As per your comment, to set a range dynamically, you can do this way:
Dim LastRow As Long
Dim r As Range
LastRow = Cells(Rows.Count, "a").End(xlUp).Row
Set r = Range("A1:b" & LastRow)
LastRow is a long which stores in the last data row in column a. Just make sure to put the column letter which you're sure it always has data to make this work properly.
Explanation:
Dim lastrow as long: This tells VBA to create a long datatype (longs are 4 bytes-sized datatypes that range from -2,147,483,648 to 2,147,483,647). variable called lastrow.
Dim r As Range: Tells VBA to create a range object. Hopefully, you know what a range is.
LastRow = Cells(Rows.Count, "a").End(xlUp).Row. We can look at this like follow:
Cells(Rows.count,"a") will return a range object delimited by the row number rows.count(the entire count of rows in the sheet) and the column a.
.End(xlup) is a property of the above range. It will return another range object however this time, it is range of non-empty cells. Xlup is the argument of this property and it basically means that the property is going to read cells from below and upwards hence the up direction. The means it will stop at the first cell that contains data from below.
The above property has returned an range object. the .Row property will return the actual number of rows in that object.
LastRow will receive that number now.
Set r = range("A1:B" & lastrow) is telling vba to set the value of the r object to a range object from ranges from "A1" to "B"&lastrow".
Now you have a dynamic range called r.