VBA paste to visible cells only - vba

I have range of cells on Sheet2 F2:F41, which I want to paste into visible cells in Sheet1. Visible cells on Sheet1 are in Range M111:M643. My Problem is, Excel pastes it to another cells as I want.
Snippet for it:
Do I miss loop or something like this?
Sheets("Tabelle2").Select
Dim tgt As Worksheet
Set tgt = ThisWorkbook.Sheets("Tabelle1")
Dim from As Range
Dim destination As Range
Set from = Sheets("Tabelle2").Range("F2:F41") Selection.Copy
Set destination = Sheets("Tabelle1").Range("M11:M643").SpecialCells(xlCellTypeVisible) from.Copy Destination:=Sheets("Tabelle1").Range("M111")

I found this on the internet - I forget where (could have been stackoverflow) - but it should do what you are looking for. You may want to edit out the plethora of messages, I find them helpful to ensure I'm copying pasting the ranges I intended.
Public Sub Copy_Paste_Visible_Cells()
'This subroutine only handles copying visible cells in a SINGLE COLUMN
Dim RangeCopy As Range
Dim RangeDest As Range
Dim rng1 As Range
Dim dstRow As Long
Set RangeCopy = Application.InputBox("Select a range to copy ", "Obtain Range Object", Type:=8)
MsgBox "The range you selected to copy is " & RangeCopy.Address
Set RangeDest = Application.InputBox("Select range to paste onto ", "Obtain Range Object", Type:=8)
MsgBox "The range you have selected to paste onto is " & RangeDest.Address
If RangeCopy.Cells.Count > 1 Then
If RangeDest.Cells.Count > 1 Then
If RangeCopy.SpecialCells(xlCellTypeVisible).Count <> RangeDest.SpecialCells(xlCellTypeVisible).Count Then
MsgBox "Data could not be copied"
Exit Sub
End If
End If
End If
If RangeCopy.Cells.Count = 1 Then
'Copying a single cell to one or more destination cells
For Each rng1 In RangeDest
If rng1.EntireRow.RowHeight > 0 Then
RangeCopy.Copy rng1
End If
Next
Else
'Copying a range of cells to a destination range
dstRow = 1
For Each rng1 In RangeCopy.SpecialCells(xlCellTypeVisible)
Do While RangeDest(dstRow).EntireRow.RowHeight = 0
dstRow = dstRow + 1
Loop
rng1.Copy RangeDest(dstRow)
dstRow = dstRow + 1
Next
End If
Application.CutCopyMode = False
End Sub

Please try this code.
Sub copythis(ByRef rFrom As Range, ByRef rTo As Range)
Dim rVisible As Range
Set rVisible = rFrom.SpecialCells(xlCellTypeVisible)
rVisible.Copy destination:=rTo
End Sub
that should be called like:
Sub caller()
copythis "range with hidden to be copied", "range to receive"
End Sub

Related

VBA copy range to another range in next empty cell

Rng1.Copy Destination:=Worksheets("RefindData").Range(Destination)
Where Rng1 is the range of data to be copied and Destination is currently a cell reference (E.g B2)
This code will be called multiple times. How can I alter this so that the destination is the same column (E.g column B) but the row is the next empty cell?
E.g so on the first call, B2 onwards is where the values are copied to, then on the next call the next empty cell after the first call is where the second call should start outputting its values. Then the next empty cell for the start of the third call, and so on.
I can alter the Destination variable to just state column letter if something like this:
Rng1.Copy Destination:=Worksheets("RefindData").Range(Destination & ???)
Is along the right lines?
Sub CopyPasteCells()
Dim Rng1 As Range, Rng2 As Range, ws As Worksheet
Set ws = Worksheets("RefindData")
Set Rng1 = ws.Range("C2:C10") 'Copy range as you like
Set Rng2 = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1, 0) 'Paste range starting from B2 and then first empty cell
Rng1.Copy Destination:=Rng2 'Copy/Paste
End Sub
You can also try something like code below.
Assumptions:
Active cell is in the column, where you want to paste the results (you want to paste results in column B -> select cell from B column [for example B2],
The first row is filled with headers, so the results gonna be pasted from second row
Code
Sub CutCopyPaste()
Dim lngCol As Long
Dim rngCopy As Range
Set rngCopy = Range("A1") 'The cell which ic copied
lngCol = Selection.Column 'active column where the results will be pasted
On Error Resume Next
rngCopy.Copy Cells(Cells(1, lngCol).End(xlDown).Row + 1, lngCol)
If Err.Number = 1004 Then
MsgBox "Be sure that active cell is in the column, where the results should be pasted!" & vbNewLine & vbNewLine & "Try again"
Err.Clear
End If
End Sub
You mean like this?
Sub Sample()
Dim rng1 As Range
Dim wsO As Worksheet
Set wsO = Worksheets("RefindData")
Set rng1 = Range("A1:A10")
rng1.Copy Destination:=wsO.Range("B" & _
wsO.Range("B" & wsO.Rows.Count).End(xlUp).Row + 1)
End Sub
Every time you run the macro it will paste in the next available row after the last row.

Copy paste three different ranges in a userform

I have two worksheets . L12 Database and Working Sheet. I have a userform which copies rows of data from any sheet to range A393 of the working sheet. However I realised that I only need to copy certain column data of that row instead of the entire row. It is split into 3 ranges , L12 Database should copy Columns A:D, I:J, and L:R. This copied data should paste into the Working Sheet Columns A:D,E:F and I:O. A previous suggestion was to do a loop through but it was only applicable to two ranges. Hence I would need some help on how I can copy and paste to three ranges in one userform. This was a code done by a stackoverflow user (Sorry I do not remember your name) which is what I roughly want to do. Thanks!
Private Sub CommandButton1_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim LngCounter As Long
If RefEdit1.Value <> "" Then
Set wsCopy = ThisWorkbook.Sheets(Replace(Split(RefEdit1.Value, "!")(0), "'", ""))
Set wsPaste = ThisWorkbook.Sheets("Working Sheet")
For LngCounter = 0 To 1
If LngCounter = 0 Then
Set rngCopy = wsCopy.Range(Split(RefEdit1.Value, "!")(1))
Set rngPaste = wsPaste.Range("A401")
Else
Set rngCopy = wsCopy.Range(Replace(Replace(Split(RefEdit1.Value, "!")(1), "A", "I"), "D", "R"))
Set rngPaste = wsPaste.Range("E401")
End If
If CheckBox1.Value = True Then
wsPaste.Activate
rngPaste.Select
rngCopy.Copy
ActiveSheet.Paste Link:=True
Else
rngCopy.Copy rngPaste
End If
Set rngPaste = Nothing
Set rngCopy = Nothing
Next
Else
MsgBox "Please select Input range"
End If
End Sub
This was the userform code I did previously:
Private Sub CommandButton1_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsCopy As Worksheet, wsPaste As Worksheet
If RefEdit1.Value <> "" Then
Set wsCopy = ThisWorkbook.Sheets(Replace(Split(RefEdit1.Value, "!")(0), "'", "")) 'Sheet name of the data selected by user
Set rngCopy = wsCopy.Range(Split(RefEdit1.Value, "!")(1)) 'Range of the data selected by user
Set wsPaste = ThisWorkbook.Sheets("Working Sheet") 'Sheet location where data copied would be pasted
Set rngPaste = wsPaste.Range("A393") 'Range Area where data copied would be pasted in columns A and B of database sheet
If CheckBox1.Value = True Then
wsPaste.Activate
rngPaste.Select
rngCopy.Copy
ActiveSheet.Paste Link:=True 'Activate paste link between info sheet and database sheet
Else
rngCopy.Copy rngPaste
End If
Else
MsgBox "Please select Input range" 'If user did not key in any input, this message wouldp pop up
End If
End Sub
edited: to fix "Solution A" Areas object handling. and added "rngPaste handling
I'll throw in two solutions
solution A
following your "scheme"
Option Explicit
Private Sub CommandButton1_Click()
Dim rngCopy As Range, rngPaste As Range, rngSelected As Areas '<~~ rngSelected is to be of "Areas" type
Dim wsCopy As Worksheet, wsPaste As Worksheet, wsActive As Worksheet
If RefEdit1.Value <> "" Then
Set rngSelected = Range(Replace(RefEdit1.Text, ";", ",")).Areas '<~~ store the selected range. Note:I had to use this Rpelace since my country customizations has addresses returned by RefEdit control Text property separed by a ";" instead of a ","
Set wsCopy = rngSelected.Parent.Parent '<~~ the parent property of Areas object returns a Range object, whose parent property eventually returns a worksheet object!
Set wsPaste = ThisWorkbook.Sheets("Working Sheet")
If Me.CheckBox1 Then '<~~ if requested...
Set wsActive = ActiveSheet ''<~~ ... store active sheet for eventually returning to it...
wsPaste.Select ''<~~ ... and activate "wsPaste" sheet once for all and avoid sheets jumping
End If
For Each rngCopy In rngSelected
Set rngPaste = Nothing '<~~ initialize rngPaste to Nothing, so that it's possible to detect its possible setting to a range if any check of Select Case block is successful
Select Case rngCopy.Columns.EntireColumn.Address(False, False) '<~~ check columns involved in each area
Case "A:D" '<~~ if columns range A to D is involved, then...
Set rngPaste = wsPaste.Range("A401") '<~~ ... have it pasted form wsPaste cell A401 on
Case "I:J" '<~~ if columns range I to J is involved, then...
Set rngPaste = wsPaste.Range("E401") '<~~ ... have it pasted form wsPaste cell E401 on
Case "L:R" '<~~ if columns range L to R is involved, then...
Set rngPaste = wsPaste.Range("I401") '<~~ ... have it pasted form wsPaste cell I401 on
End Select
If Not rngPaste Is Nothing Then '<~~ check to see if any rngPaste has been set
If Me.CheckBox1.Value Then
rngPaste.Select
rngCopy.Copy
ActiveSheet.Paste link:=True
Else
rngCopy.Copy rngPaste
End If
End If
Next rngCopy
If Me.CheckBox1 Then
wsActive.Select '<~~ if necessary, return to starting active sheet
End If
Else
MsgBox "Please select Input range"
End If
End Sub
solution B
I understand it simply suffices the user selects a single cell in a sheet and then you'll copy cells from relevant columns in that cell row and paste them into wsPaste sheet starting from corresponding cell addresses:
Private Sub CommandButton1_Click()
Dim rngSelected As Range, rngCopy As Range
Dim wsCopy As Worksheet, wsPaste As Worksheet, wsActive As Worksheet
If RefEdit1.Value <> "" Then
Set rngSelected = Range(Replace(RefEdit1.Text, ";", ",")).Areas(1).Cells(1, 1).EntireRow '<~~ store the selected range. Note:I had to use this Replace since my country customization has addresses returned by RefEdit control Text property separated by a ";" instead of a ","
Set wsCopy = rngSelected.Parent
Set wsPaste = ThisWorkbook.Sheets("Working Sheet")
If Me.CheckBox1 Then '<~~ if requested...
Set wsActive = ActiveSheet ''<~~ ... store active sheet for eventually returning to it...
wsPaste.Select ''<~~ ... and activate "wsPaste" sheet once for all and avoid sheets jumping
End If
Set rngCopy = Intersect(rngSelected, wsCopy.Columns("A:D"))
If Not rngCopy Is Nothing Then copyrng rngCopy, wsPaste.Range("A401"), Me.CheckBox1
Set rngCopy = Intersect(rngSelected, wsCopy.Columns("I:J"))
If Not rngCopy Is Nothing Then copyrng rngCopy, wsPaste.Range("E401"), Me.CheckBox1
Set rngCopy = Intersect(rngSelected, wsCopy.Columns("L:R"))
If Not rngCopy Is Nothing Then copyrng rngCopy, wsPaste.Range("I401"), Me.CheckBox1
If Me.CheckBox1 Then
wsActive.Select '<~~ if necessary, return to starting active sheet
End If
Else
MsgBox "Please select Input range"
End If
End Sub
Sub copyrng(rngCopy As Range, rngPaste As Range, okLink As Boolean)
If Not rngCopy Is Nothing Then
If okLink Then
rngPaste.Select
rngCopy.Copy
ActiveSheet.Paste link:=True
Else
rngCopy.Copy rngPaste
End If
End If
End Sub
of course, both solutions still can be optimized, for instance:
store both copying columns and corresponding pasting cells into arrays
this, to have a loop processing each "pair". so that in case your need will change again (and most probably they will...) you'll only have to add elements to the arrays while not changing code
add RefEdit return text validation
this control accepts anything typed from the user
so you may want to add a check that it's really returning a valid range
something like
If Not Range(RefEdit1.Text) Is Nothing Then... '<~~ if you expect only one selection
or
If Not Range(Range(Replace(RefEdit1.Text, ";", ",")).Areas) Is Nothing Then... '<~~ if you expect more then one selection

How to run a macro on some but not all sheets in a workbook?

I have a workbook that contains worksheets for each industry group in the S&P 500 and wrote the macro below to update all the stock information on them when I press a command button on the first worksheet. The macro works perfectly, but when I go to add additional sheets that I do not want to update with this macro it stops working. I tried using the "If Not" statements below, but it did not seem to work.
Sub Get_Stock_Quotes_from_Yahoo_Finance_API()
'Run the API for every sheet in the workbook
Dim Sht As Worksheet
For Each Sht In ThisWorkbook.Worksheets
'Look to see what the sheet is named and run the macro if it is not what is below
If Not Sht.Name = "Cover" _
And Not Sht.Name = "Select Industry" Then
Sht.Activate
' Dim varibales and set range
Dim head As Range
Set head = Worksheet.Range("A2")
'dim variables
Dim I As Integer
Dim Symbols As String: Symbols = ""
Dim SpecialTags As String: SpecialTags = ""
Dim Yahoo_Finance_URL As String: Yahoo_Finance_URL = "http://finance.yahoo.com/d/quotes.csv?s="
Dim rng As Range
Dim cell As Range
' Get the Stock Symbols
Set rng = Range(head.Offset(1, 0), head.Offset(1, 0).End(xlDown))
For Each cell In rng ' Starting from a cell below the head cell till the last filled cell
Symbols = Symbols & cell.Value & "+"
Next cell
Symbols = Left(Symbols, Len(Symbols) - 1) ' Remove the last '+'
' Get the Special Tags
Set rng = Range(head.Offset(0, 1), head.Offset(0, 1).End(xlToRight))
For Each cell In rng ' Starting from a cell to the right of the head cell till the last filled cell
SpecialTags = SpecialTags & cell.Value
Next
' Put the desciption/name of each tag in the cell above it
Dim SpecialTagsArr() As String: Dim TagNamesArr() As String
Call Get_Special_Tags(SpecialTagsArr, TagNamesArr)
For Each cell In rng
cell.Offset(-1, 0).Value = FindTagName(cell.Value, SpecialTagsArr, TagNamesArr)
Next
Yahoo_Finance_URL = Yahoo_Finance_URL & Symbols & "&f=" & SpecialTags
Call Print_CSV(Yahoo_Finance_URL, head)
Next Sht
'At the end of the program say it has all been updated
MsgBox ("All Data Updated")
End Sub
Change
If Not Sht.Name = "Cover" _
And Not Sht.Name = "Select Industry" Then
To
If Sht.Name <> "Cover" And Sht.Name <> "Select Industry" Then
Don't forget your End If before Next Sht
Refering to Kevin's second code - now the exclusion logic is flawed. I suggest the following:
Function IsIn(element, arr) As Boolean
IsIn = False
For Each x In arr
If element = x Then
IsIn = True
Exit Function
End If
Next x
End Function
Sub Get_Stock_Quotes_from_Yahoo_Finance_API()
Dim skippedSheets()
skippedSheets = Array("Cover,Select Industry,bla bla")
For Each Sh In ActiveWorkbook.Worksheets
If Not IsIn(Sh.Name, skippedSheets) Then
' ... process Sh
End If
Next Sh
End Sub
Now you have all sheet names which are to be excluded in one place (the array assignment) and the inner code block will only be executed if the current sheet name is not element of that array.
Second source of error: you already started qualifying the ranges (like in Set head = Sht.Range("A2")). Do the same in 2 other places, with
Set rng = Sht.Range(head.Offset(1, 0), head.Offset(1, 0).End(xlDown))
and
Set rng = Sht.Range(head.Offset(0, 1), head.Offset(0, 1).End(xlToRight))
Last, you don't have to activate a sheet. You work with the Sht object and qualified ranges.
Dim I as Integer is unused.

Create comments from a selected range

I basically want a macro to insert the selection as comments to a selected range. So basically I would require to have two selected ranges? How does this work?
My problem- I have the comments for the cells in a different sheet in rows. And in the second sheet I have column headers for which I need those rows as comments to be inserted.
Sub TextIntoComments_GetFromRight()
Dim cell As Range
Selection.ClearComments
For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
If Trim(cell.Offset(0, 1).Text) <> "" Then
cell.AddComment cell.Offset(0, 1).Text
cell.Comment.Visible = False
cell.Comment.Shape.TextFrame.AutoSize = True
End If
Next cell
End Sub
The following code will accept two range inputs from the user. One for the range that needs comments, and one for the range of comments. These two ranges must be the same size. It will then add the text from the second range as comments to the first range. This will work regardless of which sheet the two ranges are on.
Sub TextIntoComments_GetFromRight()
Dim CommentRange As Range
Dim CellComments As Range
Dim cell As Range
Dim cell2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Set CommentRange = Range("A1")
Set CellComments = Range("A1:A2")
Do Until CommentRange.Rows.Count = CellComments.Rows.Count And CommentRange.Columns.Count = CellComments.Columns.Count
Set CommentRange = Application.InputBox("Select the range that needs comments.", Type:=8)
Set CellComments = Application.InputBox("Select the range of comments to be inserted.", Type:=8)
If CommentRange.Rows.Count <> CellComments.Rows.Count Or CommentRange.Columns.Count <> CellComments.Columns.Count Then MsgBox "The range sizes do not match. Please select matching range sizes.", vbCritical
Loop
Set ws1 = CommentRange.Worksheet
Set ws2 = CellComments.Worksheet
CommentRange.ClearComments
For Each cell In CommentRange
Set cell2 = ws2.Cells(CellComments.Row + (cell.Row - CommentRange.Row), CellComments.Column + (cell.Column - CommentRange.Column))
If cell2.Text <> "" Then
cell.AddComment cell2.Text
cell.Comment.Visible = False
cell.Comment.Shape.TextFrame.AutoSize = True
End If
Next cell
End Sub

Compare 2 cells in different sheets in VBA(Excel 2010)

Hi Can I ask for a sample macro code to compare 2 different columns from 2 different sheets.
Here's the columnA in sheet1
Here's the column A in sheet2
Here's what I need to make as an output in sheet1
Then all cells in column A sheet1 without match such as red in the picture above should be cut and copied in column C in sheet1 like the below
lastly all cells in column A sheet 2 that has no match should be cut as well and pasted in column D in sheet 1 such as ABC:PINK, ABC:VIOLET and ABC:BLACK as shown below
Thanks for the help in advance.
Here's what I got so far
Sub Button1_Click()
On Error GoTo ErrorHndler:
Dim myRange As Range
Dim sRng As Range
Set myRange = Range("A1:A50")
Start:
For Each sRng In myRange
If sRng Like Sheets("Sheet2").Range("A1").Value Then
MsgBox (Sheets("Sheet2").Range("A1").Value) <----it does not pass here
(----I have no Idea what to put here-----)
'GoTo NextCell
Else
'GoTo Start
MsgBox (Sheets("Sheet2").Range("A1").Value)
'MsgBox "Doesn't match" <-----for debugging purposes
End If
NextCell:
Next sRng
ErrorHandler:
MsgBox ""
End Sub
You can search a range for a value using Range.Find
Range.Find returns Nothing if no match is found or a Range if a match is found.
You can check if two objects refer to the same object using the is operator.
Here is an example:
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("Sheet1").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
Range("A1:A" & TotalRows).Copy Destination:=Sheets("Sheet3").Range("A1")
'Go to the destination sheet
Sheets("Sheet3").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("Sheet2").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
End If
Next
End Sub