I am trying to copy a specific range from a protected sheet that has an autofilter with a few rows in the range filtered out.
When using the following code, only the visible rows in the range get copied:
origWB.Sheets("some data").Range("D3:LB77").Copy
targetWS.Cells(3, 4).PasteSpecial xlValues
As I said, the sheet is protected (and for various reasons I can't unprotect it within the macro), so I can't use commands that would normally solve the problem like this:
origWB.Sheets("some data").Range("D3:LB77").EntireRow.Hidden = False
I've been able to cancel the filter:
origWB.Sheets("some data").AutoFilterMode = False
This enables me to copy all the lines but then I can't figure out how to get the filter working again (as I need to leave the sheet exactly the way I found it) without getting blocked by the sheet protection.
I would appreciate either a solution that temporarily removes the filter and resumes it after the copy, or a solution that enables me to copy all the range including the hidden/filtered rows without messing with the filter itself.
The following code adds a new worksheet and copies the entire range to the new spreadsheet where you can then copy and paste where you like
I have directed the copy to be below the existing filtered data but this can be redirected
Sub CopyFilteredData()
Dim wsDst As Worksheet, tblDst As Range
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("some data")
Dim tblSrc As Range: Set tblSrc = wsSrc.Range("D3:LB77")
Set wsDst = wb.Worksheets.Add
Set tblDst = wsDst.Range(tblSrc.Address)
tblDst = "='" & wsSrc.Name & "'!" & tblSrc.Address
tblDst.Copy
tblSrc.Offset(tblSrc.Rows.Count + 1, 0).PasteSpecial xlPasteValues
Application.DisplayAlerts = False
wsDst.Delete
Application.DisplayAlerts = True
End Sub
I am not sure if it is possible to copy invisible cells by "copy". As far as i know it is not possible.
However, it is possible to read each cell value / styling properties cell by cell.
It should do the work fine for smaller ranges, but it is really slow when we have more cells (it trying to read each value instead copying entire range and this is time consuming).
Option Explicit
Sub code()
'a little performence boost
Application.ScreenUpdating = False
Dim source_cols As Integer
Dim source_rows As Integer
Dim source_range As Range
Set source_range = Sheets("SourceSheet").Range("a1:LB77")
Dim destination_range As Range
Set destination_range = Sheets("targetSheet").Range("a1")
source_cols = source_range.Columns.Count
source_rows = source_range.Rows.Count
Dim col As Integer
Dim row As Integer
For row = 1 To source_rows
For col = 1 To source_cols
'Copy value
destination_range.Offset(row - 1, col - 1).Value = source_range.Cells(row, col).Value
'Copy some extra styling if needed
destination_range.Offset(row - 1, col - 1).Interior.Color = source_range.Cells(row, col).Interior.Color
destination_range.Offset(row - 1, col - 1).Font.Color = source_range.Cells(row, col).Font.Color
destination_range.Offset(row - 1, col - 1).Font.Bold = source_range.Cells(row, col).Font.Bold
Next col
Next row
Application.ScreenUpdating = True
End Sub
However, I am recommending copy file (or worksheet at least) to remove filter, copy entire range and delete file/sheet that you just copied.
Related
I am working on a vba small code which extract date from Column A into Column C. the current code puts the formulas to extract date from Cell C2 to C2500, However if the data in Column A ends at line A600 it still goes down till C2500. Is it possible if we amend the code to stop pasting the formula exactly at the last line of Column A. so that i do not need to manually delete those cells "#Value". e.g. see print shot.
Sub Formula_property()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets("Sheet3")
wb.Activate
ws.Select
Range("C2:C2500").Formula = "=extractDate(A2:A2)"
End Sub
Assuming that all columns have the same number of rows (except column B which is empty) - we can use CurrentRegion to get the size of the target "for free"
Sub formula()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet3")
Dim rg As Range
Set rg = ws.Range("A1").CurrentRegion
Set rg = rg.Columns(1)
With rg
.Offset(1, 1).Resize(.Rows.Count - 1).formula = "=extractDate(A2:A2)"
End With
End Sub
BTW: activate/select is not necessary - I recommend reading How to avoid using select.
I am trying to loop through four tabs, copying data from three input tabs and pasting it into the remaining, master, tab. The code should loop through all the column headings on the master tab, find whether the same heading exists in any of input tabs and, if it does, copy and paste the data into the relevant column of the master tab.
At the moment, I have got all the data from the first input tab into the master tab but I am having difficulties getting data from the remaining input tabs to paste below the data from the first input tab.
This is the code as it stands at the moment:
Sub master_sheet_data()
Application.ScreenUpdating = False
'Variables
Dim ws1_xlRange As Range
Dim ws1_xlCell As Range
Dim ws1 As Worksheet
Dim ws2_xlRange As Range
Dim ws2_xlCell As Range
Dim ws2 As Worksheet
Dim ws3_xlRange As Range
Dim ws3_xlCell As Range
Dim ws3 As Worksheet
Dim ws4_xlRange As Range
Dim ws4_xlCell As Range
Dim ws4 As Worksheet
Dim valueToFind As String
Dim lastrow As String
Dim lastrow2 As String
Dim copy_range As String
'Assign variables to specific worksheets/ranges
'These will need to be updated if changes are made to the file.
Set ws1 = ActiveWorkbook.Worksheets("Refined event data - all")
Set ws1_xlRange = ws1.Range("A1:BJ1")
Set ws2 = Worksheets("Refined event data")
Set ws2_xlRange = ws2.Range("A1:BJ1")
Set ws3 = Worksheets("Refined MASH data")
Set ws3_xlRange = ws3.Range("A1:BJ1")
Set ws4 = Worksheets("Raw RHI data - direct referrals")
Set ws4_xlRange = ws4.Range("A1:BJ1")
'Loop through all the column headers in the all data tab
For Each ws1_xlCell In ws1_xlRange
valueToFind = ws1_xlCell.Value
'Loop for - Refined event data tab
'check whether column headers match. If so, paste column from event tab to relevant column in all data tab
For Each ws2_xlCell In ws2_xlRange
If ws2_xlCell.Value = valueToFind Then
ws2_xlCell.EntireColumn.Copy
ws1_xlCell.PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws2_xlCell
'Loop for - Refined ID data tab
'check whether column headers match. If so, paste column from MASH tab to the end of relevant column in all data tab
For Each ws3_xlCell In ws3_xlRange
If ws3_xlCell.Value = valueToFind Then
Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws3_xlCell
'Loop for - direct date data tab
'check whether column headers match. If so, paste column from direct J4U tab to the end of relevant column in all data tab
For Each ws4_xlCell In ws4_xlRange
If ws4_xlCell.Value = valueToFind Then
Range(ws4_xlCell.Address(), ws4_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws4_xlCell
Next ws1_xlCell
End Sub
At the moment, this section of code:
For Each ws3_xlCell In ws3_xlRange
If ws3_xlCell.Value = valueToFind Then
Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws3_xlCell
Seems to be selecting the correct range on the correct sheet and copying it. The lastrow variable seems to be picking up the correct row on the master tab but the data is not pasted. I've tried naming the ranges and using Cells() rather than Range() but neither appeared to work.
Any ideas as to how to get the data to paste would be much appreciated.
Cheers,
Ant
What I did was make a function that would find the column header and return the data range from from that column.
Sub master_sheet_data()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim cell As Range, source As Range, target As Range
With ThisWorkbook.Worksheets("Raw RHI data - direct referrals")
For Each ws In Worksheets(Array("Refined event data - all", "Refined event data", "Refined MASH data"))
For Each cell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
Set source = getColumnDataBodyRange(ws, cell.Value)
If Not source Is Nothing Then
Set target = cell.Offset(.Rows.Count - 1).End(xlUp).Offset(1)
source.Copy
target.PasteSpecial xlPasteValuesAndNumberFormats
End If
Next
Next
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Function getColumnDataBodyRange(ws As Worksheet, ColumnHeader As Variant) As Range
Dim cell As Range
With ws
Set cell = .Rows(1).Find(What:=ColumnHeader, After:=.Range("A1"))
If Not cell Is Nothing Then
Set getColumnDataBodyRange = .Range(cell.Offset(1), cell.Offset(.Rows.Count - 1).End(xlUp))
End If
End With
End Function
So I've got this sub I've pieced together that runs through all tabs in my workbook looking for a specific name, then copies all that data into a single sheet, at the next empty row.
Basically combining a bunch of similar sheets with same column format.
So my question is how do I modify this to loop through multiple groups of sheets? Right now, this is coded to only work for sheets named like "Group1" and copy into a single sheet called "raw_Group1".
How do I modify to then also look for "Group2", ... "GroupN"? The grouping name is not actually numbered, but something like "people" "stuff" "orders" etc. Each group has a different column structure and multiple sheets that I'm trying to combine.
Sub copy_Group1()
Dim ws As Worksheet
Dim Destws As Worksheet
Dim Last As Long
Dim wsLast As Long
Dim CopyRng As Range
Dim StartRow As Long
'This keeps the screen from updating until the end, makes the macro run faster
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'defines an existing "Raw_Group1" worksheet instead of creating a new one
Set Destws = ActiveWorkbook.Sheets("Raw_Group1")
'clears sheet first, leaving headers
Destws.Rows("2:" & Rows.Count).ClearContents
'Fill in the start row.
StartRow = 2
'Loop through all worksheets and copy the data to the summary worksheet.
For Each ws In ActiveWorkbook.Worksheets
If LCase(ws.Name) Like "group1*" Then
'Find the last row with data on the summary and source worksheets.
Last = LastRow(Destws)
wsLast = LastRow(ws)
'If source worksheet is not empty and if the last row >= StartRow, copy the range.
If wsLast > 0 And wsLast >= StartRow Then
'Specify the range to place the data. Four options for specifying the range
''Set CopyRng = sh.Range("A1:G1") 'whole block of columns
''Set CopyRng = ws.Range("A1:B" & LastRow) 'specific columns, to the last row
''Set CopyRng = ws.Range("B1").CurrentRegion 'uses the current block of data
Set CopyRng = ws.Range(ws.Rows(StartRow), ws.Rows(wsLast)) 'Set the range starting at row2
'Test to see whether there are enough rows in the summary worksheet to copy all the data.
If Last + CopyRng.Rows.Count > Destws.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy ' This statement copies values and formats.
'paste values only
With CopyRng
Destws.Cells(Last + 1, "A").Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
ExitTheSub:
Application.Goto Destws.Cells(1)
'filter: turns off then on (resets)
If Destws.AutoFilterMode Then Destws.AutoFilterMode = False
Destws.Range("A1").AutoFilter
'AutoFit the column width in the summary sheet.
Destws.Columns.AutoFit
'turns screen updating back on
Application.ScreenUpdating = True
End Sub
Consider generalizing your workbook processing for each group by setting up parameters into your macro with following changed lines. If certain groups need specific processing use conditional If or Select Case blocks for those particular parameter values:
Sub copy_Group(group_name As Variant, dest_sheet As Variant)
...
Set Destws = ActiveWorkbook.Sheets(dest_sheet)
...
If LCase(ws.Name) Like group_name & "*" Then
...
End Sub
And then in another macro iteratively pass all pairs of group names and destination sheets when calling your above macro. Add accordingly if you need other parameters like Start_Row and even use other data structures (i.e., collection, dictionary) instead of anonymous nested array.
Sub RunLoop()
Dim var As Variant
For Each var In Array(Array("group1", "Raw_Group1"), Array("people", "ppl_dest"), _
Array("stuff", "stuff_dest"), Array("orders", "order_dest"), _
Array("other", "other_dest"))
Call copy_Group(var(0), var(1))
Next var
End Sub
Of course there's no reason you cannot embed this loop in previous macro but this may help in code organization, even abstraction between the steps.
Hmm...#parfait...So I tried your advice here. It kinda works, but doesn't seem to be passing the 'group name' (the 1st 'type') to the first if-statement
Sub RunLoop()
Dim var As Variant
For Each var In Array( _
Array("stuff", "Raw_stuff"), _
Array("people", "Raw_people"), _
Array("orders", "Raw_orders"))
Call copy_Group(var(0), var(1)) 'calls sub listed below
Next var
End Sub
=====================
Sub copy_Group(group_name As Variant, dest_sheet As Variant)
Dim ws As Worksheet
Dim Destws As Worksheet
Dim Last As Long
Dim wsLast As Long
Dim CopyRng As Range
Dim StartRow As Long
'This keeps the screen from updating until the end, makes the macro run faster
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'defines an existing worksheet instead of creating a new one
Set Destws = ActiveWorkbook.Sheets(dest_sheet)
'clears sheet first, leaving headers
Destws.Rows("2:" & Rows.Count).ClearContents
'Fill in the start row.
StartRow = 2
'Loop through all worksheets and copy the data to the summary worksheet.
For Each ws In ActiveWorkbook.Worksheets
If LCase(ws.Name) Like group_name & "*" Then
'Find the last row with data on the summary and source worksheets.
Last = LastRow(Destws)
wsLast = LastRow(ws)
'If source worksheet is not empty and if the last row >= StartRow, copy the range.
If wsLast > 0 And wsLast >= StartRow Then
'Specify the range to place the data. Four options for specifying the range
''Set CopyRng = sh.Range("A1:G1") 'whole block of columns
''Set CopyRng = ws.Range("A1:B" & LastRow) 'specific columns, to the last row
''Set CopyRng = ws.Range("B1").CurrentRegion 'uses the current block of data
Set CopyRng = ws.Range(ws.Rows(StartRow), ws.Rows(wsLast)) 'Set the range starting at row2
'Test to see whether there are enough rows in the summary worksheet to copy all the data.
If Last + CopyRng.Rows.Count > Destws.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy ' This statement copies values and formats.
'paste values only
With CopyRng
Destws.Cells(Last + 1, "A").Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
ExitTheSub:
Application.Goto Destws.Cells(1)
'filter: turns off then on (resets)
If Destws.AutoFilterMode Then Destws.AutoFilterMode = False
Destws.Range("A1").AutoFilter
'AutoFit the column width in the summary sheet.
Destws.Columns.AutoFit
'turns screen updating back on
Application.ScreenUpdating = True
End Sub
I have an excel file like
Original File
I want to transform all the cells that filled with information into a single column. Like
To transform This
How to i do this ?
I searched in internet about that i found just only transform cells in a single row to a single cell. But i couldn't find anything like this. Can you help me about that
This is a bit of code I keep around for this kind of job. It assumes that the values in each row are contiguous, that is there are no blank cells inside the data set. It also assumes that you're on the sheet that contains the data when you trigger it, and that you want the data to be placed on a new worksheet.
Option Explicit
Sub Columnise()
Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim rngRow As Range, rngCol As Range
Dim lCount As Long
Set shtSource = ActiveSheet 'Or specify a sheet using Sheets(<name>)
Set rngCol = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set shtTarget = Sheets.Add 'Or specify a sheet using Sheets(<name>)
'Define starting row for the data
lCount = 1
'Loop through each row
For Each rngRow In rngCol
'On each row, loop through all cells until a blank is encountered
Do While rngRow.Value <> ""
'Copy the value to the target
shtTarget.Range("A" & lCount).Value = rngRow.Value
'Move one space to the right
Set rngRow = rngRow.Offset(0, 1)
'Increment counter
lCount = lCount + 1
Loop
Next rngRow
End Sub
You should end up with all the data in a single column on a new worksheet.
EDITED TO ADD: Since you mentioned your data does contain blank cells, it gets more complicated. We'll want to add a way to continue to the actual end of the data, rather than just looping until we hit a blank cell. We'll modify the Do While... condition to this:
Do While rngCell.Column <= Cells(rngCell.Row, Columns.Count).End(xlToLeft).Column
This will loop until the end of the data in the row, then move on. Give it a shot and let us know.
In reference to: Copy a row in excel if it matches a specific criteria into a new worksheet
I attempted applying the above hyperlink code to the needs of my own workbook. The only notable differences are: Object names, My data begins in "A2" instead of "A1", and my data is being copied to "L" column in a new worksheet instead of "A" column
Also... you can assume I have generated tabs in excel that correspond with each SelectCell.Value.
Sub Consolidate_Sheets()
Dim MyCell As Range
Dim MyRange As Range
Dim ws As Worksheet
Set MyRange = Sheets("Install_Input").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Call superSizeMe(MyCell, MyRange)
Sub superSizeMe(SelectCell As Range, SelectRange As Range)
Dim InstallInput As Worksheet
Dim strPasteToSheet As String
'New worksheet to paste into
Dim DestinationSheet As Worksheet
Dim DestinationRow As Range
'Define worksheet with input data
Set InstallInput = ThisWorkbook.Worksheets("Install_Input")
For Each SelectCell In SelectRange.Cells
InstallInput.Select
If SelectCell.Value <> "" Then
SelectCell.EntrieRow.Select ''''LOCATION OF RUN-TIME ERROR 438''''
Selection.Copy
Set DestinationSheet = Worksheets(SelectCell.Value)
Set DestinationRow = DestinationSheet.Range("L1:L" & DestinationSheet.Cells(Rows.Count, "L").End(xlUp).Row)
Range("L" & DestinationRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next SelectCell
InstallInput.Select
InstallInput.Cells(1, 1).Select
If IsObject(InstallInput) Then Set InstallInput = Nothing
If IsObject(SelectRange) Then Set SelectRange = Nothing
If IsObject(SelectCell) Then Set SelectCell = Nothing
If IsObject(DestinationSheet) Then Set DestinationSheet = Nothing
If IsObject(DestinationRow) Then Set DestinationRow = Nothing
End Sub
I am getting a Run-time error'438'
"Object doesn't support this property or method" on "SelectCell.EntireRow.Select"
Well your code has a typo
SelectCell.EntrieRow.Select
should say entire not Entrie. Personally I would use this method anyway, It selects the entire row based on the number you put in. FYI there is also a corresponding Columns().select if you need it in the future
sel_cell_row = SelectCell.Row
Rows(sel_cell_row).select
edit addressed to comment
The reason you get the 1004 error is like it says, the copy and paste areas don't match. Think of copying 10 rows, and trying to paste it into 2 rows, simply wouldn'y work. I'm guessing the problem actually stems from your destinationrows code. I'm not entirely sure what its trying to do, but here are two generic fixes
1)keep the copy code as it is, and modify the paste. Instead of selecting a range of cells to paste into, select the first cell (if your range was a1:a10, selecting a1 is sufficient) excel will then paste all the data starting at that first cell. so in your code do this
'comment out all this destination row stuff
'Set DestinationRow = DestinationSheet.Range("L1:L" & DestinationSheet.Cells(Rows.Count, "L").End(xlUp).Row)
'Range("L" & DestinationRow.Rows.Count + 1).Select
Range("L1").select 'only referencing the first cell to paste into
ActiveSheet.Paste
2)rather than selecting an entire row, why not select only the populated values in that row something like
sel_cell_row = SelectCell.Row
lastColumn = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column
range(Cells(sel_cell_row ,1),Cells(sel_cell_row ,lastColumn )).select
then do your copy as usual. the 1 is for column 1, or A. I'm assuming the data you want is in one row starting at column A and going till lastColumn. Maybe now this will match your destinationrows code.
3)Com,bine options 1 and 2. so copy only the populated cells, and paste to the first cell in the range