I would like to copy a range and paste it into another spreadsheet. The following code below gets the copies, but does not paste:
Sub Normalize()
Dim Ticker As Range
Sheets("Sheet1").Activate
Set Ticker = Range(Cells(2, 1), Cells(65, 1))
Ticker.Copy
Sheets("Sheet2").Select
Cells(1, 1).Activate
Ticker.PasteSpecial xlPasteAll
End Sub
How can I paste the copies into another sheet?
To literally fix your example you would use this:
Sub Normalize()
Dim Ticker As Range
Sheets("Sheet1").Activate
Set Ticker = Range(Cells(2, 1), Cells(65, 1))
Ticker.Copy
Sheets("Sheet2").Select
Cells(1, 1).PasteSpecial xlPasteAll
End Sub
To Make slight improvments on it would be to get rid of the Select and Activates:
Sub Normalize()
With Sheets("Sheet1")
.Range(.Cells(2, 1), .Cells(65, 1)).Copy Sheets("Sheet2").Cells(1, 1)
End With
End Sub
but using the clipboard takes time and resources so the best way would be to avoid a copy and paste and just set the values equal to what you want.
Sub Normalize()
Dim CopyFrom As Range
Set CopyFrom = Sheets("Sheet1").Range("A2", [A65])
Sheets("Sheet2").Range("A1").Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value
End Sub
To define the CopyFrom you can use anything you want to define the range, You could use Range("A2:A65"), Range("A2",[A65]), Range("A2", "A65") all would be valid entries. also if the A2:A65 Will never change the code could be further simplified to:
Sub Normalize()
Sheets("Sheet2").Range("A1:A65").Value = Sheets("Sheet1").Range("A2:A66").Value
End Sub
I added the Copy from range, and the Resize property to make it slightly more dynamic in case you had other ranges you wanted to use in the future.
I would try
Sheets("Sheet1").Activate
Set Ticker = Range(Cells(2, 1), Cells(65, 1))
Ticker.Copy
Worksheets("Sheet2").Range("A1").Offset(0,0).Cells.Select
Worksheets("Sheet2").paste
This is what I came up to when trying to copy-paste excel ranges with it's sizes and cell groups. It might be a little too specific for my problem but...:
'**
'Copies a table from one place to another
'TargetRange: where to put the new LayoutTable
'typee: If it is an Instalation Layout table(1) or Package Layout table(2)
'**
Sub CopyLayout(TargetRange As Range, typee As Integer)
Application.ScreenUpdating = False
Dim ncolumn As Integer
Dim nrow As Integer
SheetLayout.Activate
If (typee = 1) Then 'is installation
Range("installationlayout").Copy Destination:=TargetRange '#SHEET2 TEM DE PASSAR A SER A SHEET DO PROJECT PLAN!#####
ElseIf (typee = 2) Then 'is package
Range("PackageLayout").Copy Destination:=TargetRange '#SHEET2 TEM DE PASSAR A SER A SHEET DO PROJECT PLAN!#####
End If
Sheet2.Select 'SHEET2 TEM DE PASSAR A SER A SHEET DO PROJECT PLAN!#####
If typee = 1 Then
nrow = SheetLayout.Range("installationlayout").Rows.Count
ncolumn = SheetLayout.Range("installationlayout").Columns.Count
Call RowHeightCorrector(SheetLayout.Range("installationlayout"), TargetRange.CurrentRegion, typee, nrow, ncolumn)
ElseIf typee = 2 Then
nrow = SheetLayout.Range("PackageLayout").Rows.Count
ncolumn = SheetLayout.Range("PackageLayout").Columns.Count
Call RowHeightCorrector(SheetLayout.Range("PackageLayout"), TargetRange.CurrentRegion, typee, nrow, ncolumn)
End If
Range("A1").Select 'Deselect the created table
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
'**
'Receives the Pasted Table Range and rearranjes it's properties
'accordingly to the original CopiedTable
'typee: If it is an Instalation Layout table(1) or Package Layout table(2)
'**
Function RowHeightCorrector(CopiedTable As Range, PastedTable As Range, typee As Integer, RowCount As Integer, ColumnCount As Integer)
Dim R As Long, C As Long
For R = 1 To RowCount
PastedTable.Rows(R).RowHeight = CopiedTable.CurrentRegion.Rows(R).RowHeight
If R >= 2 And R < RowCount Then
PastedTable.Rows(R).Group 'Main group of the table
End If
If R = 2 Then
PastedTable.Rows(R).Group 'both type of tables have a grouped section at relative position "2" of Rows
ElseIf (R = 4 And typee = 1) Then
PastedTable.Rows(R).Group 'If it is an installation materials table, it has two grouped sections...
End If
Next R
For C = 1 To ColumnCount
PastedTable.Columns(C).ColumnWidth = CopiedTable.CurrentRegion.Columns(C).ColumnWidth
Next C
End Function
Sub test ()
Call CopyLayout(Sheet2.Range("A18"), 2)
end sub
You can do something like below to paste values in other ranges. (faster than copying and pasting values)
ThisWorkbook.WorkSheets("Sheet2").Range("A1:A2").Value = Sheets`("Sheet1").Range("A1:A2").Value
Related
I have a question about how to use a double loop to compare two Cells which are located in different sheets("Sheet1" and "Sheet2").
The condition I want to apply to the Loop is that in case if the two cells are different, the row must be hidden (Applied to the table located in Sheet1). In the contrary case, if the two cells are the same, the row stays as it is by default.
But with the Macro I wrote, it hides all rows that form the Sheet1 table. What could be the reason?
Sub HideRows()
Sheets("Sheet2").Select
Dim NR As Integer
NR = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
Sheets("Sheet1").Select
Dim i As Integer, j As Integer
For i = 2 To 10
For j = 1 To NR
If Cells(i, 1) <> Sheets("Sheet2").Cells(j, 1) Then
Rows(i & ":" & i).Select
Selection.EntireRow.Hidden = True
End If
Next j
Next I
End Sub
Sheet1:
Sheet2:
Desired result:
Your task is better described as
Hide all rows on Sheet1 whose column A value does not apear on Sheet2 column A
Using the looping the ranges technique you tried, this could be written as
Sub HideRows()
Dim rng1 As Range, cl1 As Range
Dim rng2 As Range, cl2 As Range
Dim HideRow As Boolean
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
rng1.EntireRow.Hidden = False
For Each cl1 In rng1.Cells
HideRow = True
For Each cl2 In rng2.Cells
If cl1.Value2 = cl2.Value2 Then
HideRow = False
Exit For
End If
Next
If HideRow Then
cl1.EntireRow.Hidden = True
End If
Next
End Sub
That said, while this approach is ok for small data sets, it will be slow for larger data sets.
A better approach is to loop Variant Arrays of the data, and build a range reference to allow hiding all required rows in one go
Sub HideRows2()
Dim rng1 As Range, cl1 As Range, dat1 As Variant
Dim rng2 As Range, cl2 As Range, dat2 As Variant
Dim HideRow As Boolean
Dim r1 As Long, r2 As Long
Dim HideRange As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat1 = rng1.Value2
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat2 = rng2.Value2
End With
rng1.EntireRow.Hidden = False
For r1 = 2 To UBound(dat1, 1)
HideRow = True
For r2 = 1 To UBound(dat2, 1)
If dat1(r1, 1) = dat2(r2, 1) Then
HideRow = False
Exit For
End If
Next
If HideRow Then
If HideRange Is Nothing Then
Set HideRange = rng1.Cells(r1, 1)
Else
Set HideRange = Application.Union(HideRange, rng1.Cells(r1, 1))
End If
End If
Next
If Not HideRange Is Nothing Then
HideRange.EntireRow.Hidden = True
End If
End Sub
#Chjris Neilsen has beaten me to most of what I wanted to mention. Please refer to his comment above. However, there are two things I want to add.
Please don't Select anything. VBA knows where everything is in your workbook. You don't need to touch. Just point.
i and j aren't really meaningful variable identifiers for Rows and Columns. They just make your task that much more difficult - as if you weren't struggling with the matter without the such extra hurdles.
With that out of the way, your code would look as shown below. The only real difference is the Exit For which ends the loop when the decision is made to hide a row. No guarantee that the procedure will now do what you want but the logic is laid are and shouldn't be hard to adjust. I point to .Rows(C).Hidden = True in this regard. C is not a row. It's a column.
Sub HideRows()
' always prefer Long datatype for rows and columns
Dim Rl As Long ' last row: Sheet2
Dim C As Long ' loop counter: columns
Dim R As Long ' loop counter: rows
Rl = WorksheetFunction.CountA(Sheet2.Columns(1))
With Sheet1
For C = 2 To 10
For R = 1 To Rl
' always list the variable item first
If Sheets("Sheet2").Cells(R, 1).Value <> .Cells(C, 1).Value Then
.Rows(C).Hidden = True
Exit For
End If
Next R
Next C
End With
End Sub
Two questions:
1) I have a spreadsheet (TC) that has data on one page that will be updated daily. There are 28 columns. Essentially I am looking to have the line (row) data cut and paste into a second spreadsheet (Archive) when Col. 28 has a value entered in it. I have the base coding but for some reason it causes Excel to be non-responsive.
I think it might be because the coding goes cell by cell rather than row by row. Can anyone point me in the right direction? (Again, keep in mind, this is a snippet of the coding - I have each Cut and Paste up to Column 28.)
2) The second part of my question is: Will what I have written make sure that when the Command Button is pressed next time, the data will cut and paste to the next blank line. Thank you!
Private Sub CommandButton1_Click()
a = Worksheets("TC").Cells(Rows.Count, 2).End(xlUp).Row
'Dim rng As Range
'Set rng = Worksheets("Archived").Range("A1")
b = 1
For i = 2 To a
If Worksheets(“TC”).Cells(i, 28).Value <> "" Then
'Change # to be the number column of Pt Name
Worksheets(“TC”).Cells(i, 1).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 1)
'Change ,# to be the number column of SOC
Worksheets(“TC”).Cells(i, 2).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 2)
b = b + 1
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets(“TC”).Cells(1, 1).Select
End Sub
You can do something like this:
Private Sub CommandButton1_Click()
Dim i as long, b As Long, shtTC as worksheet, shtArch as worksheet
Set shtTC = Worksheets("TC")
Set shtArch = Worksheets("Archive")
'find the first empty row
b = shtArch.Cells(Rows.Count, 2).End(xlUp).Row + 1 'pick a column which will always be populated
For i = 2 To shtTC.Cells(Rows.Count, 2).End(xlUp).Row
If shtTC.Cells(i, 28).Value <> "" Then
'cut the row
shtTc.Cells(i, 1).Resize(1, 28).Cut shtArch.Cells(b, 1)
b = b + 1
End If
Next
Application.CutCopyMode = False
shtTC.Cells(1, 1).Select
End Sub
Here's an example of how to create the kind of copy results you're looking for. Notice that, unless you specifically want to copy/paste all of the formatting with the data, you don't need to use copy/paste. You can perform the copy by assigning the values of the ranges.
Option Explicit
Private Sub CommandButton1_Click()
CopyData ThisWorkbook.Sheets("TC"), ThisWorkbook.Sheets("Archived")
End Sub
Public Sub CopyData(ByRef source As Worksheet, _
ByRef dest As Worksheet, _
Optional ByVal deleteSource As Boolean = False)
'--- calculate and create the source data range
Const TOTAL_COLUMNS As Long = 1
Dim srcRange As Range
Dim lastRow As Long
With source
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set srcRange = .Range("A1").Resize(lastRow, TOTAL_COLUMNS)
End With
'--- determine where the data should go
Dim destRange As Range
With dest
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lastRow > 1 Then lastRow = lastRow + 1
Set destRange = .Cells(lastRow, 1)
Set destRange = destRange.Resize(srcRange.Rows.Count, TOTAL_COLUMNS)
End With
'--- now copy the data
destRange.Value = srcRange.Value
'--- optionally delete the source data
If deleteSource Then
srcRange.Clear
End If
End Sub
This code copies the entries from Sheet1!A2, Sheet1!B2, etc. and pastes them onto Sheet2 with 3 rows between each entry. I want to duplicate this code without using .select.
Option Explicit
Sub Copy_Paste()
Dim i As Integer
For i = 1 To 100
Sheets("Sheet1").Select
Range("A2,B2,C2,D2,E2").Select
ActiveCell.Range(Cells(i, 1), Cells(i, 2)).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(((i - 1) * 4) + 1, 1).Select
ActiveSheet.Paste
Next i
End Sub
This is what I have so far, but it is not working.
Option Explicit
Sub Copy_Paste()
Dim i As Integer
For i = 1 To 100
Dim ws1 As Worksheet, rng As Range, act As Range
Set ws1 = Worksheets("Data")
Set rng = ActiveSheet.Range("A2,B2,C2,D2,E2")
Set act = ActiveCell.Range(Cells(i, 1), Cells(i, 2))
Selection.Copy
Dim ws2 As Worksheet, rng2 As Range
Set ws2 = Worksheets("Calculate")
Set rng2 = Cells(((i - 1) * 4) + 1, 1)
ActiveSheet.Paste
Next i
End Sub
I used this type of operation in one of my vba codes:
'do copy from reference "Answers_Source" worksheet
wb.Sheets("Answers_Source").Range("h1:z160").Copy
'now paste the formulas into the student exam workbook
wb2.Sheets("Answers").Range("h1:z160").Paste
So you can edit that to your situation.
you could use Offset() property of Range object
Sub Copy_Paste()
Dim i As Long
For i = 1 To 100
Sheets("Sheet1").Range("A2,B2").Offset(i - 1).Copy Destination:=Sheets("Sheet2").Range("A1:B1").Offset((i - 1) * 4)
Next
End Sub
while if you only need paste values, then it's quicker:
Sub Copy_Paste_Values()
Dim i As Long
For i = 1 To 100
Sheets("Sheet2").Range("A1:B1").Offset((i - 1) * 4).Value = Sheets("Sheet1").Range("A2,B2").Offset(i - 1).Value
Next
End Sub
You know you can just say something like "Range x values = Range y values":
ws2.Range("A1:B4").Value = ws1.Range("A1:B4").Value
If you can define your ranges using Range(Cells(1,1), Cells(4,2)) then I'm pretty sure you can do everything you want in one line
Sub getdata()
'CTRL+J
Windows("sample rnd.xlsm").Activate
Range("A1:L5215").Select
Range("A2").Activate
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Windows("rnd sample draft.xlsm").Activate
Sheets("Random Sample").Select
Sheets("Random Sample").Name = "Random Sample"
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
End Sub
Above is my code so far. It is just copying data from another another workbook and pasting it to my specified worksheet.
What I want is to get random data (rows) without duplicates and I always want to include the first row since it contains the header.
Also, I want to have a text box where I can input number so that I can specify how many data to get from the other workbook. Quite new to vba. need help.
I attached a screenshot.
One solution would be to load the rows in an array, shuffle the rows and write the array to the target:
Sub CopyRandomRows()
Dim source As Range, target As Range, randCount&, data(), value, r&, rr&, c&
' define the source to take the data
Set source = Workbooks("CheckSum3.xlsm").Worksheets("Sheet17").Range("$A$1:$B$10")
' define the target to paste the data
Set target = Workbooks("rnd sample draft.xlsm").Worksheets("Random Sample").Range("A1")
' define the number of rows to generate
randCount = 5
' load the data in an array
data = source.value
'shuffle the rows
For r = 1 To randCount
rr = 1 + Math.Round(VBA.Rnd * (UBound(data) - 1))
For c = 1 To UBound(data, 2)
value = data(r, c)
data(r, c) = data(rr, c)
data(rr, c) = value
Next
Next
' write the data to the target
target.Resize(randCount, UBound(data, 2)) = data
End Sub
a "not so smart" way to do it would be something like this:
Sub Macro1(numRows As Long)
Dim a As Long, i As Long, rng As Range
Windows("sample rnd.xlsm").Activate
a = Int(Rnd() * 5213) + 2
Set rng = Range("A1:L1")
For i = 1 To numRows
While Not Intersect(Cells(a, 1), rng) Is Nothing
a = Int(Rnd() * 5213) + 2
Wend
Set rng = Union(rng, Range("A1:L5215").Rows(a))
Next
rng.Copy
Sheets("Random Sample").Range("A1").Select
ActiveSheet.Paste
End Sub
if you are not going for a huge amount of lines... you also could put all lines in a collection and then delete one random item in it till the count reaches the number of lines you want like this (also not so smart solution):
Sub Macro2(numRows As Long)
Dim a As Long, myCol As New Collection, rng As Range
Windows("sample rnd.xlsm").Activate
For a = 2 To 5215
myCol.Add a
Next
While myCol.Count > numRows
myCol.Remove Int(Rnd() * myCol.Count) + 1
Wend
Set rng = Range("A1:L1")
For a = 1 To myCol.Count
Set rng = Union(rng, Range("A1:L5215").Rows(myCol(a)))
Next
rng.Copy
Sheets("Random Sample").Range("A1").Select
ActiveSheet.Paste
End Sub
if you still have questions, just ask ;)
Actually what i want to do , i have following data With Auto Filtering ,
-> I want to create new sheet for each unique Name selected from filtering .i.e. if John and Alex are selected then 2 new sheets should be created one for John and second for Alex , and each of them show own data (Name + No + R). When Next time if master sheet get updated then news data should be appended when i run macro. i'm using following code but its not working 100%.
Sub mycar()
x = 2
Do While Cells(x, 1) <> ""
If Cells(x, 1) = "John" Then
Worksheets("Sheet1").Rows(x).Copy
Worksheets("Sheet2").Activate
eRow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(eRow)
End If
Worksheets("Sheet1").Activate
x = x + 1
Loop
End Sub
-> Here it copy only single data Written in the quotes.
-> Second time if i run this code , it is appending same data again with new data.
Help me to avoid this mistakes.
Thank you.
As discussed there is other possibility to set filter parameters in Array in procedure. The code would look like this one:
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Arkusz1") 'or other reference to data sheet
Dim shNew As Worksheet
shData.Activate
'get unique values based on Excel features
Range("a1").AutoFilter
Dim myArr As Variant
myArr = Array("John", "max")
Range("a1").AutoFilter
Dim i As Long
For i = 0 To UBound(myArr)
shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _
Operator:=xlAnd
On Error Resume Next
Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i)
Err.Clear
End If
Next i
'removing filter in master sheet
shData.Range("a1").AutoFilter
End Sub
Substitute Worksheets("Sheet1").Rows(x).Copy by Worksheets("Sheet1").Rows(x).EntireRow.Copy
And clear the destination worksheet before adding information.
I do quite similar exercise quite often. Therefore I provide full possible solution with some comments inside the code. It works for all unique values in column A and creates (if not exists) sheet with appropriate name equals to filter parameters.
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Arkusz1") 'or other reference to data sheet
Dim shNew As Worksheet
'get unique values based on Excel features
'i guess some will not like it but I do :)
Range("a1").AutoFilter
Range("A1").CurrentRegion.Columns(1).Copy Range("ww1")
Range("ww1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
'be sure that range where you copy (like ww1) is empty range around
Dim myArr As Variant
myArr = Range(Range("ww2"), Range("ww2").End(xlDown))
Range("ww1").CurrentRegion.ClearContents 'some cleaning
Range("a1").AutoFilter '
Dim i As Long
For i = 1 To UBound(myArr, 1)
ActiveSheet.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i, 1), _
Operator:=xlAnd
On Error Resume Next
'this is for two reason- to check if appropriate sheet exists, if so to clean top area
'if you need to append you would comment this line
Sheets(myArr(i, 1)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
'if you need to append only you would need to set range-to-copy a bit different
Range("A1").CurrentRegion.Copy Sheets(myArr(i, 1)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i, 1)
Err.Clear
End If
Next i
End Sub
This could not fully meet your requirements but could be a complete solution to improve accordingly.
Heading ##Below code is as per your requirement. Modify it based upon your requirement.
Private Sub Worksheet_Calculate()
Dim x As Integer
Dim rnge As Integer
x = Range(Selection, Selection.End(xlDown)).Count
rnge = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count
If Range("E1").Value > rnge Then
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets(2).Select
ActiveSheet.Paste
End If
End Sub