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 ;)
Related
Looking for an easy way to add a certain number to each row in a column. Something like range("b1:b9")=range("a1:a9")+1
From this:
to this:
You could use Evaluate, seems quite quick.
Sub Add1()
With Range("A1:A10000")
.Value = Evaluate(.Address & "+1")
End With
End Sub
Looking for a "time-efficient" solution and avoiding loops are not the same thing.
If you were to loop over the range itself, then yes, it would be slow. Copying the range data to a Variant array, looping that, then copying the result back to the range is fast.
Here is a demo
Sub Demo()
Dim rng As Range
Dim dat As Variant
Dim i As Long
Dim t1 As Single
t1 = Timer() ' just for reportingh the run time
' Get a reference to your range by whatever means you choose.
' Here I'm specifying 1,000,000 rows as a demo
Set rng = Range("A1:A1000000")
dat = rng.Value2
For i = 1 To UBound(dat, 1)
dat(i, 1) = dat(i, 1) + 1
Next
rng.Value2 = dat
Debug.Print "Added 1 to " & UBound(dat, 1) & " rows in " & Timer() - t1; " seconds"
End Sub
On my hardware, this runs in about 1.3 seconds
FYI, the PasteSpecial, Add technique is faster still
Start the macro recorder.
type a 1 into an empty cell
copy that cell
select the cells that you want to add that value to
open the Paste Special dialog
select "Add" and OK
Stop the macro recorder. Use that code as is or work it into your other code.
Range("C1").Value = 1
Range("C1").Select
Application.CutCopyMode = False
Selection.Copy
Range("A1:A5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= False, Transpose:=False
Increase Range Values
In the following examples, the Add solution took 2.4s while the Array solution took 8.7s (on my machine) to process 5 columns.
In the Array solution, the selection is never changed, it just writes the result to the range.
The Add solution is kind of mimicking this behavior, by setting all selections as they initially were. Hence the complications.
Option Explicit
' Add Solution
Sub increaseRangeValuesTEST()
increaseRangeValues Sheet1.Range("A:E"), 1 ' 2.4s
End Sub
Sub increaseRangeValues( _
ByVal rg As Range, _
ByVal Addend As Double)
Application.ScreenUpdating = False
Dim isNotAW As Boolean: isNotAW = Not rg.Worksheet.Parent Is ActiveWorkbook
Dim iwb As Workbook
If isNotAW Then Set iwb = ActiveWorkbook: rg.Worksheet.Parent.Activate
Dim isNotAS As Boolean: isNotAS = Not rg.Worksheet Is ActiveSheet
Dim iws As Worksheet
If isNotAS Then Set iws = ActiveSheet: rg.Worksheet.Activate
Dim cSel As Variant: Set cSel = Selection
Dim aCell As Range: Set aCell = ActiveCell
Dim sCell As Range: Set sCell = rg.Cells(rg.Rows.Count, rg.Columns.Count)
Dim sValue As Double: sValue = sCell.Value + Addend
sCell.Value = Addend
sCell.Copy
rg.PasteSpecial xlPasteAll, xlPasteSpecialOperationAdd ' 95%
Application.CutCopyMode = False
sCell.Value = sValue
aCell.Activate
cSel.Select
If isNotAS Then iws.Activate
If isNotAW Then iwb.Activate
Application.ScreenUpdating = True
End Sub
' Array Solution
Sub increaseRangeValuesArrayTEST()
increaseRangeValuesArray Sheet1.Range("A:E"), 1 ' 8.7s
End Sub
Sub increaseRangeValuesArray( _
ByVal rg As Range, _
ByVal Addend As Double)
With rg
Dim rCount As Long: rCount = .Rows.Count
Dim cCount As Long: cCount = .Columns.Count
Dim Data As Variant
If rCount > 1 Or cCount > 1 Then
Data = .Value
Else
ReDim Data(1 To 1, 1 To 1): Data = .Value
End If
Dim r As Long, c As Long
For r = 1 To rCount
For c = 1 To cCount
Data(r, c) = Data(r, c) + Addend
Next c
Next r
.Value = Data ' 80%
End With
End Sub
#1. Disable your autocalculations
Application.Calculation = xlCalculationManual
#2. Disable your screenupdating
Application.ScreenUpdating = False
#3. As long as your row entries aren't more than ~56000, but your dataset is substantial then its quicker to read into an array, do the manipulations in an array, then output that array in one go.
array1 = Range(cells(3,2), cells(12,2)).value
for i = 1 to ubound(array1, 1)
array1(i, 1) = array(i, 1) + 1
next i
range(cells(3,10), cells(12,10)) = array1
Note that array1 will be 2D, and you'll be addressing (1,1) through to (10,1) in the example above
Then after pasting back in, reenable your autocalcs, THEN your screenupdate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
My first question on Stackoverflow, and a newbe, so please bare with me.
I am trying to sort out an excel sheet with 411,278 rows, about stock market data.
My code is as follows:
Sub Macro1()
'
' Macro1 Macro
'
Range("C6:C1577").Select
Selection.Copy
Range("D5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B6:C1577").Select
Range("C6").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
I am trying to insert the above code in a loop that will increment all the numbers within the loop by 1.
For example (the next phase in the loop will be):
Sub Macro1()
'
' Macro1 Macro
'
Range("C7:C1578").Select
Selection.Copy
Range("D6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B7:C1578").Select
Range("C7").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
Thanks!
A Data Transpose
The following will copy only the values (no formatting or formulas).
Adjust the values in the constants section. Note that you can choose a different worksheet for the result to leave your source data intact.
The Code
Option Explicit
Sub transposeValues()
' Define constants.
Const srcName As String = "Sheet1"
Const srcColumns As String = "B:D"
Const srcFirstRow As Long = 5
Const dstName As String = "Sheet1"
Const dstFirstCell As String = "B5"
Const dCount As Long = 1573
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Range.
Dim rng As Range
With wb.Worksheets(srcName).Columns(srcColumns)
Set rng = .Resize(.Worksheet.Rows.Count - srcFirstRow + 1) _
.Offset(srcFirstRow - 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - srcFirstRow + 1).Offset(srcFirstRow - 1)
End With
' Write values from Source Range to Data Array.
Dim Data As Variant: Data = rng.Value
' Define Result Array.
Dim srCount As Long: srCount = UBound(Data)
Dim Remainder As Long: Remainder = srCount Mod dCount
Dim drCount As Long
If Remainder = 0 Then
drCount = srCount / dCount
Else
drCount = Int(srCount / dCount) + 1
End If
Dim dcCount As Long: dcCount = dCount + 1
Dim Result As Variant: ReDim Result(1 To drCount, 1 To dcCount)
' Declare counters.
Dim i As Long, j As Long, k As Long
' Write values from Data Array to Result Array.
If drCount = 1 And Remainder > 0 Then
i = 1
Else
For i = 1 To drCount + (Remainder <> 0) * 1 ' In VBA 'True = -1'.
k = k + 1
For j = 1 To 2
Result(i, j) = Data(k, j)
Next j
For j = 3 To dcCount
k = k + 1
Result(i, j) = Data(k, 2)
Next j
Next i
End If
' Write the remainder of values in Data Array to Result Array.
If Remainder > 0 Then
k = k + 1
For j = 1 To 2
Result(i, j) = Data(k, j)
Next j
If Remainder > 1 Then
For j = 3 To 1 + Remainder
k = k + 1
Result(i, j) = Data(k, 2)
Next j
End If
End If
' Write values from Result Array to Destination Range.
With wb.Worksheets(dstName).Range(dstFirstCell).Resize(, dcCount)
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(drCount).Value = Result
End With
End Sub
Please do not try this code without taking precautions.
Sub Macro1()
Dim Rng As Range
Dim Rstart As Long ' start of range row
Dim Rend As Long ' end of range row
Dim Target As Range ' destination of copy action
Dim DelRng As Range ' range to delete
Rstart = 6
Rend = 1577
Application.ScreenUpdating = False
Do
Set Rng = Range(Cells(Rstart, "C"), Cells(Rend, "C"))
Set Target = Cells(Rstart - 1, "D")
Set DelRng = Range(Cells(Rstart, "B"), Cells(Rend, "C"))
Rng.Copy
TargetPasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
DelRng.Delete Shift:=xlUp
Rstart = Rstart + 1
Loop Until Rstart = Rend
With Application
.CutCopyMode = False
.ScreenUpdating = False
End With
End Sub
Primary precaution to take is to understand the code. Start and End rows are specified at the top. They are used to set 3 ranges in columns C, D and B:C. Initially, they are precisely your 3 ranges Range("C6:C1577"), Range("D5"), Range("B6:C1577"). The code copies from the first range to the second and then deletes the third. It does so without selecting anything because once VBA is told where a range is it doesn't need to select it.
You will notice that there is no equivalent of your Range("C7").Activate. That's because C7 is within the range Range("B6:C1577") which is earmarked for destruction. It makes no difference which cell in it is active. However, I have some doubt about the deletion and whether you actually meant to delete only this cell (which your code doesn't do). Please check my code against your intentions in this regard.
Now the critical part. That's the loop. On each iteration the 3 ranges are moved one row down. The line of code requiring your attention is this one.
Loop Until Rng.Row = Rend
The loop will continue until the first row of the first range is equal to Rend. That means that there will be 1571 loops - probably enough time to have a coffee and a chat even while screen updating is turned off. But even this fearsome number is definitely wrong. Your question gives no clue as to your needs but I guess it should be like Loop Until Rng.Row = (411278 - Rend), give or take 1. I didn't want to enter into an argument about this final, last row (which tends to be omitted in loops) while not believing that your number of rows is invariable. I think it should be replaced with a formula that finds the last existing row in a particular column.
However, your question was how to advance the ranges. My code does that beautifully. Enjoy the show.
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
I have a file that has 5 transaction codes ("IPL","ISL","IMO","IIC","CAPO").
I need my macro to find the first 4 transaction codes in column dc of worksheets("sort area"), if it locates it, then take the contents of DE-FN and copy values to a new sheet.
for the last transaction code, i need the macro to find the transaction code in dc, and if it's there take the contents of the row but only the subsequent 8 columns (DE-DL) copy paste values in to worksheet("flat file") and then take the next 8 columns (DM-DS) from the original sheet ("sort area") and copy values in worksheet("flat file") but the following row
for the first part of the macro, i have it separated in to two parts, where i am copying the contents of the entire row, pasting values in to a new sheet, and then sorting the contents and deleting unneeded columns in the new sheet.
I'm struggling because my code is skipping some rows that contain IPL and i don't know why.
i have no idea how to do the last part, CAPO.
Part A (this takes the IPL transaction code and moves it to the new sheet ("flat file"):
Sub IPLFlat()
Dim xRg As Range
Dim xCell As Range
Dim xRRg1 As Range
Dim xRRg2 As Range
Dim I As Long
Dim J As Long
Dim K As Long
Dim xC1 As Long
Dim xFNum As Long
Dim xDShName As String
Dim xRShName As String
xDShName = "sort area"
xRShName = "flat file"
I = Worksheets(xDShName).UsedRange.Rows.Count
J = Worksheets(xRShName).UsedRange.Rows.Count
xC1 = Worksheets(xDShName).UsedRange.Columns.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets(xRShName).UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets(xDShName).Range("DC2:DC" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "IPL" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = Worksheets(xRShName).Range("A" & J + 1).EntireRow
xRRg2.Value = xRRg1.Value
If CStr(xRg(K).Value) = "IPL" Then
K = K + 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
'Sort Flatfile tab
Worksheets("flat file").Activate
With ActiveSheet.Sort
.SortFields.Add Key:=Range("DF1"), Order:=xlAscending
.SetRange Range("A1", Range("FG" & Rows.Count).End(xlUp))
.Header = xlNo
.Apply
End With
Columns("A:DD").EntireColumn.Delete
Here is a solution:
Sub stackOverflow()
Dim sortSheet As Worksheet, flatSheet As Worksheet, newSheet As Worksheet
Set sortSheet = ThisWorkbook.Sheets("sort area")
Set flatSheet = ThisWorkbook.Sheets("flat file")
Dim rCount As Long, fCount As Long
rCount = sortSheet.Cells(sortSheet.Rows.Count, 1).End(xlUp).Row
For i = 2 To rCount
Select Case sortSheet.Cells(i, 107).Value
Case "IPL", "ISL", "IMO", "IIC"
Set newSheet = ThisWorkbook.Sheets.Add
sortSheet.Range(sortSheet.Cells(i, 109), sortSheet.Cells(i, 170)).Copy 'de->109 fn->170
newSheet.Paste
Case "CAPO"
With flatSheet
fCount = .Cells(.Rows.Count, 1).End(xlUp).Row
sortSheet.Range(sortSheet.Cells(i, 109), sortSheet.Cells(i, 116)).Copy 'de->109 dl->116
.Range(.Cells((fCount + 1), 1), .Cells((fCount + 1), 8).PasteSpecial Paste:xlPasteValues
sortSheet.Range(sortSheet.Cells(i, 117), sortSheet.Cells(i, 123)).Copy 'dm->117 ds->123
.Range(.Cells((fCount + 2), 1), .Cells((fCount + 2), 6).PasteSpecial Paste:xlPasteValues
End With
End Select
Next i
End Sub
I hope I understood your problem correctly and that this helps,
Cheers
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