Copy_Paste_Visible_Cells_Only - excel

I have been trying to Copy the Filtered data and pasting the data on filtered cell but my code is not working.
I have data in Range Sheet2.Range("O2:O10000") and i filtered this range to Sheet2.Range("O173:O2400").
I want to copy the data from filtered cells Sheet2.Range("O173:O2400") then paste this data to visible cells on same Sheet2.Range("N173:N2400")
Please note there are multiple hidden rows in this range.
Any help will be appreciated
Sub Copy_Paste__Visible_Cells_Only()
Sheet2.Range("O173:O2400").SpecialCells(xlCellTypeVisible).Copy
Sheet2.Range("N173:N2400").SpecialCells(xlCellTypeVisible).Paste
End Sub

In this case, pasting won't work. As far as I know, you can't change the paste behaviour to only paste to visible cells.
When you select visible cells only, you get a collection of areas (you can think of them as a discontinuous set of ranges). Given you're just trying to move your visible data to the left, you can do it by looping through the areas and assigning their values to the same area in the previous column. Something like this:
Public Sub CopyVisible()
Dim a As Range
For Each a In Sheet1.Range("O4:O17").SpecialCells(xlCellTypeVisible).Areas
a.Offset(0, -1).Value = a.Value
Next
End Sub
The .Offset(0,-1) is signalling that you wish the values to be moved one column to the left
You can see from this example, when I filter on "a" in column O and run the macro, only the "a" values are moved to column N.

I would use a generic sub copyVisibleCellsToOtherColumn to which you pass the source-range and the target-start range.
Advantage you can re-use it for different scenarios.
Sub test_CopyVisibleCells()
Dim rgSource As Range
Set rgSource = sheet2.Range("O173:O2400")
Dim rgTarget As Range
Set rgTarget = sheet2.Range("N173:02400")
copyVisibleCells rgSource, rgTarget
End Sub
'this ist the generic sub
Public Sub copyVisibleCellsToOtherColumn(rgSource As Range, rgTarget As Range)
Dim c As Range, a As Range
For Each a In rgSource.Areas
'this will return the visible cells within rgsource
For Each c In a.Cells
rgTarget.Rows(c.Row).Value = c.Value
Next
Next
End Sub

I found code from somewhere which able to copy visible cells and paste into visible cells. For easy usage, I manually assign a shortcut ctrl+shift+C to call the macro.
Public Sub Copy_Range_Paste_Into_Visible_Cells()
'Sub Copy_Range_Paste_Into_Visible_Cells()
Dim rngSource As Range, rngDestination As Range, cell As Range, cc As Long, i As Long
On Error Resume Next
Application.DisplayAlerts = False
Set rngSource = Application.InputBox("Select the filtered range to copy. ", "Select Filtered Cells", Type:=8)
If rngSource Is Nothing Then Application.DisplayAlerts = True: Exit Sub 'User canceled
Set rngDestination = Application.InputBox("Select the destination cell to paste to. ", "Select Paste Destination", Type:=8)
If rngDestination Is Nothing Then Application.DisplayAlerts = True: Exit Sub 'User canceled
On Error GoTo 0
Application.DisplayAlerts = True
cc = rngSource.Columns.Count
For Each cell In rngSource.Columns(1).SpecialCells(xlCellTypeVisible)
Do Until Not rngDestination(1).Offset(i).EntireRow.Hidden
i = i + 1
Loop
rngDestination(1).Offset(i).Resize(1, cc).Value = cell.Resize(1, cc).Value
i = i + 1
Next
End Sub

Related

Copy & Paste range into next available columns

I have a range of data - B5:AG1004
In the macro, I need to copy this range and paste it in the next available column. The dedicated space for pasting begins in AX5.
In the code I have now, it copies and pastes the range into the desired (first) position, however once I click the command button again it re-pastes into the exact same place i.e. overwriting the original paste. I need the next iteration to paste in the next available cells to the right.
Here is my code so far;
Sub columnmacro()
ActiveSheet.Range("B5:AG1004").Copy
Sheets("Optimise").Range("ax5").End(xlToLeft).Offset(, 1).PasteSpecial xlValues
Application.CutCopyMode = False
End Sub
Hopefully someone can help, thanks!
Try this:
Sub SubColumnMacro()
'Declarations.
Dim RngSource As Range
Dim RngDestination As Range
'Setting variables.
Set RngSource = ActiveSheet.Range("B5:AG1004")
Set RngDestination = Sheets("Optimise").Range("AX5").Resize(RngSource.Rows.Count, RngSource.Columns.Count)
'Finding the next avaiable spot on the right to report RngSource values.
Do Until Excel.WorksheetFunction.CountBlank(RngDestination) = RngDestination.Cells.Count
Set RngDestination = RngDestination.Offset(0, 1)
Loop
'Reporting Rngsource values in RngDestination.
RngDestination.Value = RngSource.Value
End Sub

Hide all Rows except matching value

I'm working with some data in excel spanning B9:AJ1108 - so multiple rows and columns. I am looking to hide all rows except where the value in column B matches the number in cell C5.
I've tried multiple and can only just about get everything to hide but the unhiding is the issue. I understand how to hide all and how to unhide all. What I need help with is how to hide all and then unhide if something matches the value in C5.
Code so far:
Private Sub CommandButton2_Click()
Worksheets("Employee information").Range("B9:B1108").Rows.Hidden = False
End Sub
Private Sub CommandButton1_Click()
Worksheets("Employee information").Range("B9:B1108").Rows.Hidden = True
'Need to put in the argument to search for C5 value
End Sub
I would also like this to be button controlled but I don't know if that is a case of creating a module or just code within the sheet?
For unhiding the rows you can use "Rows.EntireRow.Hidden = False"
If you want to use a button for the macro to get executed, create a button and excel will ask you which macro you want to get when you click the button.
value= Worksheets("Employee information").cells(5,3).value
That will give you the value of the cell C5, now you need to go through the rows and look for this value.
Hide Rows Not Containing Criteria in Column
Private Sub CommandButton1_Click()
With Worksheets("Employee information")
' Define Criteria (restrict to numbers).
Dim Criteria As Variant
Criteria = .Range("C5").Value
If Not IsNumeric(Criteria) Then
Exit Sub
End If
' Define Criteria Range.
Dim rng As Range
Set rng = .Range("B9:B1108")
End With
' Declare additional variables.
Dim hRng As Range ' Hide Range
Dim cel As Range ' Current Cell (in Source Range)
Dim CurVal As Variant ' Current Value (of Current Cell in Source Range)
' Create a union (Hide Range) of all the cell ranges
' that do not contain Criteria.
For Each cel In rng.Cells
' Evaluate Current Value.
CurVal = cel.Value
If IsNumeric(CurVal) Then
If CurVal = Criteria Then
GoTo NextCell ' Match found: do nothing.
End If
End If
' Match not found: add Current Cell to Hide Range.
If Not hRng Is Nothing Then
Set hRng = Union(hRng, cel)
Else
Set hRng = cel
End If
NextCell:
Next cel
' Hide rows of Hide Range.
If Not hRng Is Nothing Then
hRng.Rows.Hidden = True
End If
End Sub

Copy values of named range referenced in another cell

I want to create a loop that copies one range to another, dependent on the value in a list. The list contains the names of all the ranges that I want to copy.
So in this example, PolicyOutput is a named range from DD15:DD77. I want it to update with values from another range, policy1, then loop to copy new values again from a different cell range, policy2.
The list of policies is in a range of cells called PolicyChoice
Each row of PolicyChoice contains a reference to a group of cells. It will be values: policy1, policy2, policy3 etc.
The values of the cells refer to named ranges. For example policy1 is A15:A77, and policy2 is B15:B77
I want A15:A77 to copy to DD15:DD77, then B15:B77 to copy to DD15:DD77, but in a way that can be updated and rerun as the list of "PolicyChoice" is changed by the user.
I tried the code below, but it just copies "policy1" over again into each cell in the range PolicyOutput, instead of the values in the range policy1
policyChoiceCount = (Sheets("RunModel").Range("policyChoice").Count) - Application.WorksheetFunction.CountIf(Sheets("RunModel").Range("policyChoice"), "")
For h = 1 To PolicyChoiceCount
Sheets(PolicySheetName).Range("PolicyOutput").Value = WorksheetFunction.Index(Sheets("RunModel").Range("policyChoice"), h)
Next h
Thanks!
Add Range(WorksheetFunction ..).value like this
Sheets(policySheetName).Range("PolicyOutput").Value = _
Range(WorksheetFunction.Index(Sheets("RunModel").Range("policyChoice"), h)).Value
or in simple steps
Sub mycopy()
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
Dim rngSource As Range, rngTarget As Range, cell As Range
Set wb = ThisWorkbook
Set wsSource = wb.Sheets("RunModel")
Set wsTarget = wb.Sheets("PolicySheetName")
Set rngTarget = wsTarget.Range("PolicyOutput")
For Each cell In wsSource.Range("PolicyChoice")
If Len(cell) > 0 Then
On Error Resume Next
If IsEmpty(Range(cell)) Then
MsgBox "No named range " & cell, vbCritical, "ERROR"
Exit Sub
End If
On Error GoTo 0
rngTarget.Value = Range(cell).Value
End If
Next
End Sub

Looping through comments on an excel workbook in vba with merged cells

I have a workbook, with multiple sheets, which have comments. I have to loop through each of the sheets and pick up the comments. I have implemented the following logic.
For Each Ip_Sheet In ActiveWorkbook.Worksheets
Set Rng = Ip_Sheet.Cells.SpecialCells(xlCellTypeComments)
If Rng Is Nothing Then
MsgBox "No comments in the sheet"
Else
For Each cell In Rng
Comment_Author_NameAndComment = Split(cell.Comment.Text, ":")
AuthName = Comment_Author_NameAndComment(0)
AuthComments = Comment_Author_NameAndComment(1)
The above logic works fine if there are no merged cells in the worksheet. However, if there are merged cells/rows, the loop For Each cell In Rng runs for each of the cells in the merged cells range. For example, if columns A:D are merged, then the loop runs for each of the cells A, B, C and D and I get the same value in the AuthName and AuthComments variables.
My question is, how do I make the loop to skip to the next comment on the worksheet if I find a merged cell?
Edit:
I also tried to loop through all the comments in the sheet by the following method, however, the method was not successful - the Rng.Comment object was always empty.
For Each cmnt_obj In Rng.Comment
cmt_txt = cmnt_obj.Text
Next cmnt_obj
Since SpecialCells(xlCellTypeComments) returns all cells for a Merged Range, you need to detect when a cell is part of a named range and only process one of those cells. You can use Range.MergeCells to detect a merged cell, and Range.MergeArea to return the merged range itself. Then only report the comment if the cell is the Top Left cell of the merged range.
Something like this:
Sub Demo()
Dim rng As Range
Dim cl As Range
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
Set rng = ws.Cells.SpecialCells(xlCellTypeComments)
If Not rng Is Nothing Then
For Each cl In rng.Cells
If cl.MergeCells Then
If cl.Address = cl.MergeArea.Cells(1).Address Then
ReportComment cl
End If
Else
ReportComment cl
End If
Next
End If
Next
End Sub
Sub ReportComment(cl As Range)
Dim Comment_Author_NameAndComment() As String
Dim AuthName As String
Dim AuthComments As String
Comment_Author_NameAndComment = Split(cl.Comment.Text, ":")
AuthName = Comment_Author_NameAndComment(0)
AuthComments = Comment_Author_NameAndComment(1)
Debug.Print AuthName, AuthComments
'...
End Sub

Clear Contents of Visible Cells in Filtered Column

I'm filtering on a helper cell to locate cells in column B that need the contents cleared. Once I filter on the helper cell that has identified cells in column B that need contents cleared, I am having issues clearing the contents in that cell.
I got the general idea down except I cannot figure out how to clear the visible cells only starting from the first visible cell down to the last visible cell. My issue is identifying where is the start of the first visible cell after the filter is applied and where is the last visible cell.
Sub Macro1()
'
' Macro1 Macro
Dim wb As Workbook
Dim ws As Worksheet
Dim FoundCell1 As Range
Set wb = ActiveWorkbook
Set ws = ActiveSheet
'This identifying the row of the last cell to filter on
Const WHAT_TO_FIND1 As String = "Tango"
Set FoundCell1 = ws.Range("AX:AX").Find(What:=WHAT_TO_FIND1)
'This is filtering on the helper cell to determine what cells need to be cleared.
ws.Range("$BA$8:$BA$" & FoundCell1.Row).AutoFilter Field:=1, Criteria1:= _
"Delete"
'This is where I'm having issues. I would like to replace B2 with a more dynamic code
'that finds the first visible cell after the filter is applied and start there.
'I think the xlUp solves the issue of finding the last visible cell but I am not sure
'if that is the best or correct method.
ws.Range("B2:B" & Rows.Count).End(xlUp).SpecialCells(xlCellTypeVisible).ClearContents
End Sub
Here's how I'd do it:
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim FoundCell1 As Range
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
'This identifying the row of the last cell to filter on
Const WHAT_TO_FIND1 As String = "Tango"
Set FoundCell1 = ws.Range("AX:AX").Find(What:=WHAT_TO_FIND1)
If FoundCell1 Is Nothing Then Exit Sub 'WHAT_TO_FIND1 not found
'This is filtering on the helper cell to determine what cells need to be cleared.
With ws.Range("$BA$8:$BA$" & FoundCell1.Row)
If .Row < 8 Or .Rows.Count = 1 Then Exit Sub 'No data
.AutoFilter Field:=1, Criteria1:="Delete"
On Error Resume Next 'Suppress error in case there are no visible cells
Intersect(.Worksheet.Columns("B"), .Offset(1).Resize(.Rows.Count - 1).EntireRow).SpecialCells(xlCellTypeVisible).ClearContents
On Error GoTo 0 'Remove "On Error Resume Next" condition
.AutoFilter
End With
End Sub

Resources