I have used the following code, but it is very specific:
Sub Macro 6 ()
Windows("Projects_Europe2014 work.xlsx").Activate
Range("B12:C16").Select
Selection.Copy
Windows("test1.xlsx").Activate
ActiveSheet.Paste
Windows("Projects_Europe2014 work.xlsx").Activate
Range("D12:E16").Select
Application.CutCopyMode = False
Selection.Copy
Windows("test1.xlsx").Activate
Range("F3").Select
ActiveSheet.Paste
Windows("Projects_Europe2014 work.xlsx").Activate
Range("F12:G16").Select
Application.CutCopyMode = False
Selection.Copy
Windows("test1.xlsx").Activate
Range("J3").Select
ActiveSheet.Paste
End Code
Is there a way, i can keep increasing the range, without manually entering the cde?
Does the worksheet you are copying to contains preexisting data? If not you could just copy your whole range and then insert empty columns where need be - after every two consecutive columns involving data
You can try the below and see if it fits - you need to fill in your references first where commented. "RANGE_REF" is the starting point cell where pasting of the original range should occur
Sub pasteandinsert()
Dim r As Range
Dim r2 As Range
'HERE
Set r = Workbooks("Projects_Europe2014 work.xlsx").Worksheets("YOUR_WS").Range("YOUR_RANGE")
r.Copy
'HERE
With Workbooks("test1.xlsx").Worksheets("YOUR_WS2")
.Activate
'HERE
.Range("RANGE_REF").Select
.Paste
End With
Application.CutCopyMode = False
'HERE
Set r2 = Range("RANGE_REF").Resize(r.Rows.count, r.Columns.count)
i = 3
colcount = r2.Columns.count
Do While i <= colcount
r2.Columns(i).Insert shift:=xlShiftToRight
r2.Columns(i).Insert shift:=xlShiftToRight
i = i + 4
colcount = colcount + 2
Loop
End Sub
Related
I have two sheets. One has the complete data and the other is based on the filter applied on the first sheet.
Name of the data sheet : Data
Name of the filtered Sheet : Hoky
I am just taking a small portion of data for simplicity. MY objective is to copy the data from Data Sheet, based on the filter. I have a macro which somehow works but its hard-coded and is a recorded macro.
My problems are:
The number of rows is different everytime. (manual effort)
Columns are not in order.
Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"
'Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste
End Sub
Best way of doing it
Below code is to copy the visible data in DBExtract sheet, and paste it into duplicateRecords sheet, with only filtered values. Range selected by me is the maximum range that can be occupied by my data. You can change it as per your need.
Sub selectVisibleRange()
Dim DbExtract, DuplicateRecords As Worksheet
Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")
DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Cells(1, 1).PasteSpecial
End Sub
I suggest you do it a different way.
In the following code I set as a Range the column with the sports name F and loop through each cell of it, check if it is "hockey" and if yes I insert the values in the other sheet one by one, by using Offset.
I do not think it is very complicated and even if you are just learning VBA, you should probably be able to understand every step. Please let me know if you need some clarification
Sub TestThat()
'Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long
'Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")
Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
'I went from the cell row3/column6 (or F3) and go down until the last non empty cell
i = 2
For Each rCell In SportsRange 'loop through each cell in the range
If rCell = "hockey" Then 'check if the cell is equal to "hockey"
i = i + 1 'Row number (+1 everytime I found another "hockey")
HokySh.Cells(i, 2) = i - 2 'S No.
HokySh.Cells(i, 3) = rCell.Offset(0, -1) 'School
HokySh.Cells(i, 4) = rCell.Offset(0, -2) 'Background
HokySh.Cells(i, 5) = rCell.Offset(0, -3) 'Age
End If
Next rCell
End Sub
When i need to copy data from filtered table i use range.SpecialCells(xlCellTypeVisible).copy. Where the range is range of all data (without a filter).
Example:
Sub copy()
'source worksheet
dim ws as Worksheet
set ws = Application.Worksheets("Data")' set you source worksheet here
dim data_end_row_number as Integer
data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
'enable filter
ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
Application.Worksheets("Hoky").Range("B3").Paste
'You have to add headers to Hoky worksheet
end sub
it needs to be .Row.count not Row.Number?
That's what I used and it works fine
Sub TransfersToCleared()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Application.Worksheets("Export (2)") 'Data Source
LastRow = Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A2:AB" & LastRow).SpecialCells(xlCellTypeVisible).Copy
The purpose of this VBA is to make a single long row of values (tens of thousands) into something more readable by keeping each row limited to 22 values. I have a manual version of this which works for 200 rows, but am hoping to use looping to save myself time and hopefully improve performance.
Example:
I have values in A1:ZZ1 and am trying to cut W1:ZZ1 and paste into A2, then cut W2:ZD2 and paste into A3 until there are no values left to cut and paste.
I'm using Excel 2010.
Sub InsertScript22perLine()
'Turn off screen updating to speed up macro
Application.ScreenUpdating = False
Range("W1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Selection.End(xlToLeft).Select
Range("A2").Select
ActiveSheet.Paste
Range("W2").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Selection.End(xlToLeft).Select
Range("A3").Select
ActiveSheet.Paste
'Turn screen updating back on
Application.ScreenUpdating = True
End Sub
Sub InsertScript22perLine()
Application.ScreenUpdating = False
' Starting column for input data
Dim sStartCol As String
Dim lStartCol As Long
' Count of columns
Dim lColCount As Long
' Count of columns of data for output
Dim lRowLen As Long
lRowLen = 22
Dim lRow As Long
lRow = 2
sStartCol = "W"
lStartCol = Range(sStartCol & 1).Column
' Get the column count
lColCount = Cells(1, Columns.Count).End(xlToLeft).Column
For a = lStartCol To lColCount Step lRowLen
Range(Cells(lRow, 1), Cells(lRow, lRowLen)).Value = Range(Cells(1, a), Cells(1, a + lRowLen)).Value
lRow = lRow + 1
Next
Application.ScreenUpdating = True
End Sub
NOTE: if you are personally unclear on something in this post, constructive route is to ask with specifics of what do you need clarification on.
I have following code, which does what I need - it works with the only pivot table on active worksheet. These pivot tables always have only two columns. Selection excludes header/footer, selects only data. Copies 1st column, pastes it to the right of the 2nd column. Expands selection to include pasted data and second column - copies that.
Issue: how to exclude from copying a row if it contains "(blank)"
Sub PivotPrep4POST()
'
' PivotPrep4POST Macro
'
Application.ScreenUpdating = False
Dim pt As PivotTable
Set pt = ActiveSheet.PivotTables(1)
Dim ws As Worksheet
'selects Row range of pivot
pt.RowRange.Select
'trims two last rows off selection
Selection.Resize(Selection.Rows.Count - 2, Selection.Columns.Count + 0).Select
'shifts selection one row down, resulting in selection minus top and bottom row
Selection.Offset(1, 0).Select
Selection.Copy
Selection.Offset(0, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Resize(Selection.Rows.Count - 0, Selection.Columns.Count + 1).Select
Selection.Offset(0, -1).Select
Selection.Copy
Application.ScreenUpdating = True
'
End Sub
Instead of copying row by row, I suggest it will be much easier and more efficient to filter out blanks, and copy the whole lot in one go to where you need it. Or if you want to rearrange the order of the columns, then copy it column by column.
To see code on filtering out blanks, see Pivot Field Show All Except Blank
Jon Peltier has a great post on referencing PivotTable Ranges at https://peltiertech.com/referencing-pivot-table-ranges-in-vba/
Added a bit of code that resizes selection one row short, if it contains "blank" - and this works:
Sub PivotPrep4POST2()
'
' PivotPrep4POST Macro
'
Application.ScreenUpdating = False
Dim pt As PivotTable
Set pt = ActiveSheet.PivotTables(1)
Dim ws As Worksheet
'selects Row range of pivot
pt.RowRange.Select
'trims two last rows off selection
Selection.Resize(Selection.Rows.Count - 2, Selection.Columns.Count + 0).Select
'shifts selection one row down, resulting in selection minus top and bottom row
Selection.Offset(1, 0).Select
Selection.Copy
Selection.Offset(0, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Resize(Selection.Rows.Count - 0, Selection.Columns.Count + 1).Select
Selection.Offset(0, -1).Select
'Added this
Dim SrchRng As Range, cel As Range
Set SrchRng = Selection
For Each cel In SrchRng
If InStr(1, cel.Value, "blank") > 0 Then
Selection.Resize(Selection.Rows.Count - 1, Selection.Columns.Count + 0).Select
End If
Next cel
'end of addition
Selection.Copy
Application.ScreenUpdating = True
'
End Sub
I threw this together real quick. If you want to check more than one column, you would need to modify, but this should get you started.
Sub PivotPrep4POST()
'
' PivotPrep4POST Macro
'
Application.ScreenUpdating = False
Dim pt As PivotTable
Set pt = ActiveSheet.PivotTables(1)
Dim ws As Worksheet
'selects Row range of pivot
pt.RowRange.Select
'trims two last rows off selection
Selection.Resize(Selection.Rows.Count - 2, Selection.Columns.Count + 0).Select
'shifts selection one row down, resulting in selection minus top and bottom row
Selection.Offset(1, 0).Select
Selection.Copy
Selection.Offset(0, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Resize(Selection.Rows.Count - 0, Selection.Columns.Count + 1).Select
Selection.Offset(0, -1).Select
'New Code (7/11/2018)
Dim rCell As Range, newRng As Range, tRng As Range
Set tRng = Selection
For Each rCell In tRng.Columns(1).Cells
If rCell.Value2 <> "(blank)" Then
If newRng Is Nothing Then
Set newRng = Intersect(rCell.EntireRow, tRng)
Else
Set newRng = Union(newRng, Intersect(rCell.EntireRow, tRng))
End If
End If
Next rCell
newRng.Select
'End new code
Selection.Copy
Application.ScreenUpdating = True
'
End Sub
I have a workbook that uses a macro to add extra lines, as the workbook has to be heavily locked down to protect it from users. I'm using Excel 2010.
However, if I have two windows open looking at different sheets of the workbook, running the macro makes both windows shift to the sheet in which I added the lines(s), which is disruptive to workflow.
My guess is that this is down to using .PasteSpecial but I am unsure of how else to do it, as the lines to be added include formatting and formulae so .value = .value won't work.
The sub is called from one of four other subs; one to add a single row, one to add multiple rows, one to add a special header row, and one that adds costs rows (done by sending a negative number of rows). The code is:
Sub InsertAnyRows(NumRows As Integer)
Dim thisWS As Worksheet
Set thisWS = ActiveSheet
If Not (InRange(ActiveCell, thisWS.Range("QuoteLines")) Or InRange(ActiveCell, thisWS.Range("LabourLines")) Or InRange(ActiveCell, thisWS.Range("OptionsLines"))) Then Exit Sub
Application.ScreenUpdating = False
Application.CutCopyMode = False
Dim RowLoc As Range
Set RowLoc = thisWS.Cells(Selection.Rows(1).Row, 1)
Select Case NumRows
Case Is < 0 ' must be inserting costs rows
NumRows = NumRows * -1
RowLoc.Resize(NumRows).Offset(1, 0).EntireRow.Insert
thisWS.Range("CostsBlankRow").Copy
RowLoc.Resize(NumRows).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Case 0 ' must be inserting a header row
RowLoc.Offset(1, 0).EntireRow.Insert
thisWS.Range("TabHeaderRow").Copy
RowLoc.Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Case Else ' must be inserting normal rows
RowLoc.Resize(NumRows).Offset(1, 0).EntireRow.Insert
thisWS.Range("TabBlankRow").Copy
RowLoc.Resize(NumRows).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
End Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
This is rather messy and I'm sure there is a more elegant solution, but in a quick test adding these lines after End Select seemed to preserve the windows.
Windows(1).Activate
thisWS.Activate
Windows(2).Activate
Sheets(2).Activate 'adjust sheet name/index to suit
This is what I came up with, so that it'll deal with an arbitrary number of open windows; it also reselects whatever the selection was before running the macro (which looks neater to me). Thank you for the pointers!
Sub InsertAnyRows(NumRows As Integer)
Dim thisWS As Worksheet
Set thisWS = ActiveSheet
If Not (InRange(ActiveCell, thisWS.Range("QuoteLines")) Or InRange(ActiveCell, thisWS.Range("LabourLines")) Or InRange(ActiveCell, thisWS.Range("OptionsLines"))) Then Exit Sub
Application.ScreenUpdating = False
Application.CutCopyMode = False
Dim NumWindows As Integer
NumWindows = ThisWorkbook.Windows.Count
If NumWindows > 1 Then
Dim Windows() As Window
Dim WindowsSheets() As Worksheet
ReDim Windows(NumWindows)
ReDim WindowsSheets(NumWindows)
Dim i As Integer
For i = 1 To NumWindows
Set Windows(i) = ThisWorkbook.Windows(i)
Set WindowsSheets(i) = Windows(i).ActiveSheet
Next i
End If
Dim RowLoc As Range, EndLoc As Range, SelRange As Range
Set SelRange = Selection
Set RowLoc = thisWS.Cells(Selection.Rows(1).Row, 1)
Select Case NumRows
Case Is < 0 ' must be inserting costs rows
NumRows = NumRows * -1
RowLoc.Resize(NumRows).Offset(1, 0).EntireRow.Insert
thisWS.Range("CostsBlankRow").Copy
RowLoc.Resize(NumRows).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Case 0 ' must be inserting a header row
RowLoc.Offset(1, 0).EntireRow.Insert
thisWS.Range("TabHeaderRow").Copy
RowLoc.Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Case Else ' must be inserting normal rows
RowLoc.Resize(NumRows).Offset(1, 0).EntireRow.Insert
thisWS.Range("TabBlankRow").Copy
RowLoc.Resize(NumRows).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
End Select
SelRange.Select
If NumWindows > 1 Then
For i = NumWindows To 1 Step -1
Windows(i).Activate
WindowsSheets(i).Activate
Next i
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I have 2 sheets, sheet1 and sheet2. From sheet1 data, I have to copy data and paste it into sheet2, then again from sheet1 I have to copy another different set of data and paste it into sheet2 last line, where I pasted data 1st time.
Sub Copy_chains_to_other_sheet()
ActiveSheet.Range("$A$1").AutoFilter Field:=8, Criteria1:="<>1", _
Operator:=xlAnd
ActiveSheet.Range("$A$1:$I$681").AutoFilter Field:=1, Criteria1:="=*antaris*" _
, Operator:=xlAnd
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
ActiveSheet.Next.Select
ActiveSheet.Paste
ActiveSheet.Range("$A$1").AutoFilter Field:=1
End Sub
This is the macro I wrote, but I don't know how to proceed. Because one time I have 5 rows of data that time I need to copy data from sheet1 and paste in sheet2 and with next set of data I need to paste it in 6th row, but another time I have 8 row of data that time I need to paste the next set of data from 9the row onwards, so how to deal with this.
If I understand correctly you want to copy the results of successive autofiltered data from Sheet1 to a continuous "list" in Sheet2. If this is so then perhaps try the following to get you going. You will need to alter the variables/names to suit your requirement, I have made some assumptions.
Option Explicit
Sub copyAFs()
Dim wsONE As Worksheet, wsTWO As Worksheet
Dim ONEstrow As Long, ONEendrow As Long, ONEstcol As Long, ONEendcol As Long
Dim TWOstrow As Long, TWOnextrow As Long, TWOstcol As Long
Dim crit1col As Long, crit2col As Long
Dim crit1 As String, crit2 As String
Set wsONE = Sheets("Sheet1")
Set wsTWO = Sheets("Sheet2")
ONEstrow = 1
ONEstcol = 1
ONEendcol = 10
TWOstrow = 1
TWOstcol = 1
crit1 = "antaris"
crit2 = "1"
crit1col = 1
crit2col = 8
With wsTWO
TWOnextrow = .Cells(.Rows.Count, TWOstcol).End(xlUp).Row + 1
End With
'clear autofilter
wsONE.AutoFilterMode = False
'apply autofilter
With wsONE
ONEendrow = Cells(Rows.Count, ONEstcol).End(xlUp).Row + 1
With .Range(.Cells(ONEstrow, ONEstcol), .Cells(ONEendrow, ONEendcol))
'set autofilter
.AutoFilter Field:=crit1col, Criteria1:=crit1
.AutoFilter Field:=crit2col, Criteria1:=crit2
End With
End With
'copy filtered range without header
With wsTWO
wsONE.AutoFilter.Range.Offset(1, 0).Copy Destination:=.Range(.Cells(TWOnextrow, TWOstcol), .Cells(TWOnextrow, TWOstcol))
End With
'clear autofilter
wsONE.AutoFilterMode = False
End Sub