I want to copy data from specific column in Sheet 1 to a specific column in Sheet 2. There are 20 such columns and that mapping is maintained in a table like
I have written the code to search column name (source and destination sheets) from but am unable to copy the data from source column (dynamic range) to destination column.
Sub search_validate()
Dim j As Integer
Dim sourcSearch, destSearch As String
Dim sCell, dCell As Range
For j = 3 To 20
sourcSearch = Sheet6.Range("Z" & j).Value ' pickup selected source column name
destSearch = Sheet6.Range("AA" & j).Value ' pickup selected destination column name
Set sCell = Sheet1.Rows(2).Find(What:=sourcSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Set dCell = Sheet2.Rows(2).Find(What:=destSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
' sCell.Address or sCell.Column to get source column header address but data starts after this column. dynamic range
' dCell.Address or dCell.Column to get destination column header address. no data in destination column except header.
Next j
End Sub
This should append the data to the end of the destination column
If Not sCell Is Nothing And Not dCell Is Nothing Then
Dim Source As Range, Target As Range
Set Source = Intersect(Sheet1.UsedRange, sCell.EntireColumn).Offset(1)
Set Target = Sheet2.Cells(Sheet2.Rows.Count, dCell.Column).End(xlUp).Offset(1)
Source.Copy Destination:=Target
End If
You need to paste new data after last row in your current table?
U can find last row with this:
lastRow = Columns("Enter your column number here").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Then just make a copy-paste, like this:
Set copyRange = Range(YOUR RANGE HERE)
copyRange.Copy
Cells(lastRow + 1, "Enter your column number here").PasteSpecial Paste:=xlPasteValues
Related
I have a table of data in a sheet that i am looking to make some adjustments to. I have a single column called "S/R" which will have one of two values in it [Serving OR Returning]. If the value is serving i want to copy the value from a column called "1stServeX" to a new column i have added i called "Server 1st Serve X".
I have written the code below but am beginning to trip myself up and also cannot finish the last part. I am a novice and so have been using other pieces of code i have gained previously to try and piece it together, which is why i need some help.
If i can get this going then i can simply repeat it for all the "Returner" option and all the other columns i need to split too.
Thanks in advance for any help offered.
Public Sub splitServerCoordinates()
'Set a constant for the title of the Server Column
Const HEADER_SR As String = "S/R"
Dim ws As Worksheet
Set ws = Sheets("transition")
Dim strSearch As String
Dim aCell As Range
Dim COL_SR As Long
Dim COL_TARGET As Long
Dim COL_CURRENT As Long
'Find the Column Numbers of the columns we are looking for
strSearch = "S/R"
Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
COL_SR = aCell.Column
End If
strSearch = "1stServeX"
Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
COL_CURRENT = aCell.Column
End If
strSearch = "Server 1st Serve X"
Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
COL_TARGET = aCell.Column
End If
Dim theUsedRange As Range
Dim SRRange As Range
Dim aPlayer As Range
Dim serving As String
Dim returning As String
Dim theCounter As Long
Dim theSequence As Long
ws.Select
' clear out the Target column and add the header again
Set theUsedRange = ActiveSheet.UsedRange
Intersect(theUsedRange, Range(Columns(COL_TARGET), Columns(COL_TARGET))).ClearContents
Columns(COL_SR).Range("A1").Value = HEADER_SR
' reset the used range just in case
Set theUsedRange = ActiveSheet.UsedRange
' Get the used range for the S/R column
Set SRRange = Intersect(theUsedRange, Columns(COL_SR))
'Set value to compare to
serving = "Serving"
' Loop through the S/R column
For Each aPlayer In SRRange
' ignore the header row
If aPlayer <> HEADER_SR Then
' if we are serving then copy the value from COL_CURRENT to COL_TARGET
If aPlayer = serving Then
aPlayer.Offset(-1, COL_TARGET - COL_).Value = STUCK - HERE
End If
End If
Next aPlayer
End Sub
Some refactoring to pull out the column header location parts, and a few other tweaks. Untested, but should get you there.
Public Sub splitServerCoordinates()
Dim ws As Worksheet, c As Range
Dim COL_SR As Long
Dim COL_TARGET As Long
Dim COL_CURRENT As Long
Set ws = Sheets("transition")
'Find the Column Numbers of the columns we are looking for
COL_SR = HeaderColumnNumber(ws.Rows(1), "S/R")
COL_CURRENT = HeaderColumnNumber(ws.Rows(1), "1stServeX")
COL_TARGET = HeaderColumnNumber(ws.Rows(1), "Server 1st Serve X", True) 'add if not found
'exit if missing any required columns
If COL_SR = 0 Or COL_CURRENT = 0 Then
MsgBox "Missing 'S/R' and/or '1stServeX' !"
Exit Sub
End If
'reset target column
ws.Columns(COL_TARGET).ClearContents
ws.Cells(1, COL_TARGET).Value = "Server 1st Serve X"
'loop rows
For Each c In ws.Range(ws.Cells(2, COL_SR), ws.Cells(ws.Rows.Count, COL_SR).End(xlUp)).Cells
If c.Value = "Serving" Then
ws.Cells(c.Row, COL_TARGET).Value = ws.Cells(c.Row, COL_CURRENT).Value
End If
Next c
End Sub
'Find a header position on a row, with option to add it if not found
' Returns zero if header is not found and option to add was not set
Function HeaderColumnNumber(rng As Range, hdr As String, _
Optional AddIfMissing As Boolean = False) As Long
Dim f As Range
Set rng = rng.Cells(1).EntireRow 'only want a full row to look in
Set f = rng.Find(What:=hdr, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not f Is Nothing Then
HeaderColumnNumber = f.Column 'found: return column
Else
'not found: do we add it, or return zero?
If AddIfMissing Then
With rng.Cells(rng.Cells.Count).End(xlToLeft).Offset(0, 1)
.Value = hdr
HeaderColumnNumber = .Column
End With
Else
HeaderColumnNumber = 0
End If
End If
End Function
I am currently automating a sales report with VBA and I am having trouble with inserting a formula using VBA with a dynamic range. My Formula with Lookup finds the last week that a client ordered.
The current week is the last week and is always the column prior to the Total column. I am having trouble referencing that last column with the current week.
=LOOKUP(2,1/(CL[#[Week 1]:[Week 17]]>0),COLUMN(CL[[#Headers],[Week 1]:[Week 17]]))
I wasn't sure how to reference using headers.
So the first part of my code finds the column number and using the column number I get the Letter reference. Not sure how to use the Letters with my LOOKUP formula
Sub LastOrder()
Dim strSearch As String
Dim strSearchEnd As String
Dim aCell As Range
Dim endCell As Range
Dim startingCol As Variant
Dim endingCol As Variant
Dim colFirstWeek As Variant
Dim ColLastWeek As Variant
Dim firstCheck As Variant
Dim lastCheck As Variant
'find the column number for week 1 and total
strSearch = "Week 1"
strSearchEnd = "Total"
Set aCell = Sheet1.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
startingCol = aCell.Column
End If
Set endCell = Sheet1.Rows(1).Find(What:=strSearchEnd, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not endCell Is Nothing Then
endingCol = endCell.Column - 1
'this is used to get column number of current week
End If
'Use letter reference
firstCheck = Split(Cells(, startingCol).Address, "$")(1)
lastCheck = Split(Cells(, endingCol).Address, "$")(1)
Debug.Print (firstCheck)
Debug.Print (lastCheck)
Range("CL[Last Week Ordered]").FormulaR1C1 = _
"LOOKUP(2,1/(firstCheck:lastCheck>0),COLUMN(firstCheck:lastCheck))
You can try this formula :
=LOOKUP(2, 1 / ( [#[Week 1]]:INDEX([#], , COLUMNS([#]) - 1) > 0 ),
COLUMN( [#[Week 1]]:INDEX([#], , COLUMNS([#]) - 1) ) )
Few Excel Functions like INDEX and OFFSET return Range reference, so they can be used with the range operator :, and Range("INDEX(A1:B1, 1, 1)") in VBA.
My macro needs to do some calculations on rows and import data where the user enters an ID. Main thing it's running on the specified ID because there is some data that needs updating/doublechecking so running running the entire source file is not ideal.
My code basically asks the user to enter an ID as 'criteria', and then this gets compared with a dictionary I created containing all data from the source, the problem is that using dict.Item doesn't really compare IDs though it runs on every single row correctly in the destination sheet.
'dictionary filler
For indexsrsrow = 2 To indexsrslastrow
dict.Add CStr(srcWorksheet.Range("A" & indexsrsrow).Value), indexsrsrow
Next indexsrsrow
dim criteria as string
criteria = inputbox("enter id")
For indexdstrow = 2 To indexlastdstrow
'IF ID EXIST AND ITEM = CRITERIA AND C COLUMN IS EMPTY
If dict.Exist(criteria) And destinerow.Cells(indexdstrow, "C") = "" Then
'STUFF HAPPENS HERE
End If
Next indexdstrow
Set dict = Nothing
Is there other way to compare dictionary items with an specified user input?.
Thanks in advance.
#SiddharthRout Kinda, e.g. Im the user and I need to update the record (row) with id 123 so I run the macro, it asks me for the id that I need to update, I input 123 and when I press enter, in the code it should get the id on the source workbook, grab the data and paste it in the destination workbook where the id is 123. Hope this clarifies. –
I have commented the code so you should not have a problem understanding it. Let me know if this is what you want? If not then post your query and I will look at it when I wake up.
Option Explicit
Sub Sample()
Dim srcWorksheet As Worksheet, destinerow As Worksheet
Dim dict As New Dictionary
Dim lRow As Long, i As Long
'~~> Set your source and destination worksheets
Set srcWorksheet = Sheet1
Set destinerow = Sheet2
'~~> Add items to dict from Source worksheet
With srcWorksheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
dict.Add CStr(.Range("A" & i).Value), i
Next i
End With
'~~> Ask user for the criteria
Dim criteria As String
criteria = InputBox("enter id")
'~~> If user presses cancel or item doesn't
'~~> exists in dictionary then exit sub
If criteria = "" Then Exit Sub
If Not dict.Exists(criteria) Then Exit Sub
Dim rngToCopy As Range, aCell As Range
'~~> Find the id in source so we can identify the
'~~> range to copy
With srcWorksheet
Set aCell = .Range("A1:A" & lRow).Find(What:=criteria, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'~~> I am ssuming the data that you want to copy
'~~> is in Col B. If not then change as applicable
Set rngToCopy = .Range("B" & aCell.Row)
End If
End With
Set aCell = Nothing
'~~> Find the id in destinations so we can identify the
'~~> range where we need to copy
With destinerow
Set aCell = .Columns(1).Find(What:=criteria, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'~~> I am ssuming the data WHERE you want to copy
'~~> is in Col C. If not then change as applicable
rngToCopy.Copy .Range("C" & aCell.Row)
End If
End With
End Sub
To give you a breakdown of my spreadsheet:
I have a master spreadsheet that pulls data from another spreadsheet (generated daily), placing it into the next empty column and converting the column that previously held the formula to values. This is achieved with a combination of the following formula and VBA code:
=IF(ISNA(VLOOKUP("Row 1",'N:\Reports\[data.xls]Sheet1'!$A$2:$B$40,2,FALSE)),0,(VLOOKUP("Row 1",'N:\Reports\[data.xls]Sheet1'!$A$2:$B$40,2,FALSE)))
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rLastCell As Range
Dim LastCol As Integer
Set rLastCell = ws.Cells.Find(what:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
LastCol = rLastCell.Column
ws.Columns(LastCol).Copy ws.Columns(LastCol + 1)
With ws.Columns(LastCol)
.Copy .Offset(0, 1)
.Value = .Value
End With
End Sub
The intention is for Column B to be a 'totals' column, that dynamically sums all of the values in the relevant row as new entries are pulled by the formula/VBA combo and added to the first blank column. Unfortunately though, I also need to subtract that row's total from the value that the formula returns--however, doing so creates a circular reference.
My solution was to just exclude the last cell in the row (that has the formula) from the total, with this:
=SUM(C2:OFFSET(I$2,0,-1))
However, the dynamic range doesn't appear all that dynamic. It doesn't expand to include the next column when a new record is added, and I'm really not enough of a hand at this stuff to figure out why or how to rectify it.
Thanks in advance for any assistance with this and please don't hesitate to ask for any clarification!
It may be simplest to use a named range. If you name the column before the monthly total say LastDay, you can use:
=SUM(C2:INDEX(LastDay,ROW())
as your formula, and your code then becomes:
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rLastCell As Range
Dim LastCol As Integer
Set rLastCell = ws.Cells.Find(what:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
LastCol = rLastCell.Column
With ws.Columns(LastCol)
.Copy .Offset(0, 1)
.Value = .Value
.Name = "LastDay"
End With
End Sub
Assuming I have understood your layout correctly.
I am trying to develop code to do the following:
1)Copy cells K4: M4 in Workbook 1, Sheet 1 <- I can do this step;
2)Find a cell in Workbook2, Sheet1, column C that matches cell B4 in
Workbook1, Sheet1;
3)Paste the copied values in columns P:R of the matching row in
Workbook 2, Sheet 1 as determined in Step 2.
My apologies in advance for being unable to advance my own work beyond step 1. I am, as I said, completely new to this and have scoured the web for an answer/learnings up until this point, without turning up a solution.
I tested this and it worked. Does this help you get started?
Sub CopyToMatchedRow()
Dim copyRng As Range, matchVal As Variant, matchRng As Range, matchRow As Integer
Set copyRng = Worksheets("Sheet1").Range("K4:M4")
Set matchRng = Worksheets("Sheet2").Range("C:C")
matchVal = Worksheets("Sheet1").Range("B4")
matchRow = matchRng.Find(What:=matchVal, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
copyRng.Copy Destination:=Worksheets("Sheet2").Range("P" & matchRow & ":R" & matchRow)
End Sub