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
Related
I having difficulty copying specific columns into another sheet.
Sub FindthenCopy()
'Excel VBA find the position of a header
Dim source As Range
Set ws1 = Worksheets("CheckSheet")
For i = 1 To 50
If Sheets(ActiveSheet.Name).Cells(1, i).Value = "User ID" Then
Sheets(ActiveSheet.Name).Columns(i).Select
Set source = Selection
source.Copy ([ws1])
Exit For
End If
Next i
End Sub
Your problem is you're specifying the destination as a worksheet, it needs to be a cell
source.Copy ([ws1])
should be
source.copy ws1.range("A1") 'or whichever column you want - must be row 1 though
as #HarassedDad already told you, you must specify a starting cell in thebsheet you want to past values
furthermore ActiveSheet is the default implicit sheet reference assumed and you don't need all that Select and Selection:
Sub FindthenCopy()
Dim ws1 As Worksheet
Set ws1 = Worksheets("CheckSheet")
Dim i As Long
For i = 1 To 50
If Cells(1, i).Value = "User ID" Then
Columns(i).Copy ws1.Cells(1, 1)
Exit For
End If
Next i
End Sub
you may also want to use Find() method and avoid looping:
Sub FindthenCopy()
Dim source As Range
Set source = Rows(1).Find(what:="User ID", LookIn:=xlValues, lookat:=xlPart)
If Not source Is Nothing Then source.EntireColumn.Copy Worksheets("CheckSheet").Cells(1, 1)
End Sub
or, if you know for sure that "User ID" string is to be found in active sheet row 1:
Sub FindthenCopy()
Rows(1).Find(what:="User ID", LookIn:=xlValues, lookat:=xlPart).EntireColumn.Copy Worksheets("CheckSheet").Cells(1, 1)
End Sub
Try sth like this:
Option Explicit
Sub CopyCol()
Dim source As Range
Dim i As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
For i = 1 To 50
If ws.Cells(1, i) = "User ID" Then
ws.Columns(i).Select
Selection.Copy
Worksheets.Add 'Add new sheet
ActiveSheet.Cells(1, 1).Select ' select a cell where your data
'suppose to be copy to
ActiveCell.PasteSpecial (xlPasteAll) 'paste data
Exit For
End If
Next i
End Sub
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
I have the following workbook called master:
Column I Column K
1234
1222
1111
I also have a workbook called slave:
Column J Column R
1234 Ambient
1222 Ambient
1111 Chiller
When the user enters/pastes the number in column I on my master workbook, i want to check if the same number exists in my slave workbook in column J.
If it does, i want to copy the corresponding prodcut groups from column R over to my master workbook in column K.
The other problem is my slave workbook changes name from time to time, but will always contain the word 'Depot memo' like so:
Food Depot Memo
Drinks Depot Memo 01-19
etc.
I am trying to reference my slave workbook by checking if the file name contains 'depot memo'.
For some reason this is not working. Please can someone show me where i am going wrong?
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = True
Dim Dic As Object, key As Variant, oCell As Range, i As Long
Dim w1 As Worksheet, w2 As Worksheet
If Not Intersect(Target, Range("I:I")) Is Nothing Then ' <-- run this code only if a value in cell C5 has change
Application.EnableEvents = False
Set Dic = CreateObject("Scripting.Dictionary")
If Not Dic.exists(Target.Value) Then
Dic.Add Target.Value, Target.Offset(1, 0).Value
End If
Dim wbInd As Integer
Dim wb2 As Workbook
For wbInd = 1 To Workbooks.Count ' <-- loop through all open workbooks
If Workbooks(wbInd).Name Like "Depot Memo*" Then '<-- check if workbook name contains "volumes"
Set wb2 = Workbooks(wbInd)
Exit For
End If
Next wbInd
On Error GoTo message
Set w2 = wb2.Sheets(1)
With w2
i = .Cells(.Rows.Count, "J").End(xlUp).Row
End With
For Each oCell In w2.Range("J6:J" & i)
For Each key In Dic
If oCell.Value = key Then
Target.Offset(0, 2).Value = oCell.Offset(0, 8) '<-- put the the value in column F (offset 1 column) to cell C6 (one row offset)
End If
Next
Next
End If
Application.EnableEvents = True
Exit Sub
message:
Exit Sub
End Sub
EDIT:
With the suggested code from #user3598756 i encounter this problem:
If the user copy and pastes these values, rather than typing them, the correct supplier number does not correspond with the item number in column I.
This is obviously not correct, since it should have a different supplier number for each different item number.
edited to handle multiple changed cells
one thing that doesn't work as you'd expect is :
Like "Depot Memo*
that would not detect neither "Food Depot Memo" nor "Drinks Depot Memo 01-19"
while you have to use
Like "*Depot Memo*"
Furthermore:
there's no need for any Dictionary object
you don't need to iterate with For Each oCell In w2.Range("J6:J" & i)
so I'd go with the following refactoring of your code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oCell As Range, targetCell As Range
Dim ws2 As Worksheet
If Not Intersect(Target, Range("I:I")) Is Nothing Then ' <-- run this code only if a value in column I has changed
If Not GetWb("Depot Memo", ws2) Then Exit Sub
With ws2
For Each targetCell In Target
Set oCell = .Range("J1", .Cells(.Rows.count, "J").End(xlUp)).Find(what:=targetCell.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not oCell Is Nothing Then
Application.EnableEvents = False
targetCell.Offset(0, 2).Value = oCell.Offset(0, 8)
Application.EnableEvents = True
End If
Next
End With
End If
End Sub
Function GetWb(wbNameLike As String, ws As Worksheet) As Boolean
Dim wb As Workbook
For Each wb In Workbooks
If wb.name Like "*" & wbNameLike & "*" Then '<-- check if workbook name contains "Depot Memo"
Set ws = wb.Worksheets(1)
Exit For
End If
Next
GetWb = Not ws Is Nothing
End Function
The wildcard in "Depot Memo*" name check should appear at the beginning AND the end of the text. This would detect if a workbook name contains any text before and/or after "Depot Memo".
If Workbooks(wbInd).Name Like "*Depot Memo*" Then
I have the following code:
Sub test()
Dim r As Range, rng As Range
Set r = Range("a6", Range("a6").End(xlDown))
For Each rng In r
If rng <> rng.Offset(-1) Then 'if range is not
Dim ws As Worksheet
Set ws = Worksheets.Add
ws.Name = rng
Else
End If
Next rng
End Sub
This would go through the range in A6 to AXX and create a worksheets for different names. I somehow can't figure out however how to copy the content of every row into every worksheet created.
So I want all the Ticker changes being copied into the new created worksheet ticker changes.
I know there is some way with the following:
Range(Cells(rng, 1), Cells(rng, 10)).Copy
But I don't know how to paste those to different worksheet.
Can someone please advice or guide. Thanks
Also when I try to run this macro it sometimes says:
That name is already taken try a different one.
However there is no worksheet with that name.
You only need to reference/specify the sheet that you want to use.
Try this (I included an inputbox to correct the name of the sheet if it is already taken :
Sub test_Nant()
Dim r As Range, rng As Range, ws As Worksheet, aWs As Worksheet
Set aWs = ActiveSheet
Set ws = Worksheets.Add
On Error GoTo SheetRename
ws.Name = "Changes list"
GoTo KeepLooping
SheetRename:
ws.Name = InputBox("Choose another name for that sheet : ", , rng.Value)
Resume Next
KeepLooping:
With aWs
Set r = .Range(.Range("a6"), .Range("a6").End(xlDown))
For Each rng In r
If rng <> rng.Offset(-1) Then 'if range is not
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 10)).Copy Destination:=ws.Range("A1")
Else
End If
Next rng
End With
End Sub
I am trying to use AdvancedFilter in VBA, but instead of setting copy to range to a fixed value I want to copy it to the first empty row.
I am trying to append two tables from two separate AdvancedFilter steps, is there an easier way? E.g. first copy the two tables to separate location and then merge them? Both table have the same columns.
My code as of now is:
Set rngCriteria_v = Sheets("1").Range("filter")
Set rngExtract_v = Sheets("2").Range("**Here first empty row**")
Set rngData_v = Sheets("3").Range("Input")
rngData_v.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rngCriteria_v, _
CopyToRange:=Sheets("Stocks_5_control").Columns("AG").Find(vbNullString, Cells(Rows.Count, "AG")), _
Unique:=False
Change your advanced filter line to this:
rngData_v.AdvancedFilter xlFilterCopy, rngCriteria_v, Sheets("Stocks_5_control").Cells(Sheets("Stocks_5_control").Rows.Count, "AG").End(xlUp)(2)
The following merges the all the worksheets in to a new sheet called Master. Hope that helps :)
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Dim wd As Object 'used for word document
Dim WDoc As Object
Dim strWorkbookName As String
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit