Find values of a column in another and paste range of rows
 

Hello,

I have a problem: I have a monthly sheet (Month.xls) with the number of the clients in one column, and their info on the following ones. In the Tab "Exp" I have this:


I also have another file (Year.xls), in which I must paste the data of the columns in yellow of the monthly sheet,(paste special: values, transposed). In the Tab "Year" I have this:


To determine the offset for the month in which I want it to be pasted, in the monthly sheet I have a cell in the Tab "Start", cell A3, where I put the number of the month. For September, for example, is 9.

I want a macro for Month.xls that will look for the clients number in column B of Year.xls, find it in column A of Month.xls, copy the rows from columns C to G and paste them, transposed, in the correct month of the Year.xls.

How do I do that?

Find values of a column in another and paste range of rows
 

Kurt,

The code below should work. Just copy it to a new module and adjust any of the code that you need as applicable.

Hope this helps,

Ben

Code:


Option Explicit

Sub MonthToYear()
Dim wsYear As Worksheet 'Destination Sheet
Dim wsMonth As Worksheet 'Source Sheet
Dim rAdd As Range 'Range with month number
Dim rCell As Range 'Client number cells
Dim rCopy As Range 'Client information
Dim rPaste As Range 'Destination cells
Dim strError As String 'Error message
Dim x As Long '# of Errors
Dim y As Long '# of Clients

'Set sources of data
Set wsYear = Sheets("Year")
Set wsMonth = Sheets("Month")
Set rAdd = Sheets("Start").Range("A3")
x = 0
y = 0

'Loop through each client on Month sheet and paste data to applicable month if client found
For Each rCell In wsMonth.Range("A2:A" & wsMonth.Range("A50000").End(xlUp).Row)
Set rCopy = rCell.Offset(0, 2).Resize(1, 5) 'Client data range
Set rPaste = GetRange(rCell.Value, wsYear, rCell) 'Calls a function to get paste range
If rPaste.Address = rCell.Address Then 'Could not find client number on Year tab
strError = strError & rCell.Value & vbCr 'Build error message
x = x + 1 'Increment the error counter
Else
rCopy.Copy 'Copy the client data and paste special to Year tab
rPaste.Offset(0, 1 + rAdd.Value).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
End If
y = y + 1 'Increment client counter
Next rCell

'Now that all data is complete, display a message
If x 0 Then 'Errors occurred
If x = y Then 'No client numbers found
MsgBox "None of the client numbers could not be found. Clients searched include: " _
& vbCr & vbCr & strError, vbOKOnly, "Clients not found"
Else 'Some clients found, others not found
MsgBox "The following client client numbers could not be found: " & vbCr & vbCr & _
strError & vbCr & vbCr & "All others transferred succesfully.", vbOKOnly, _
"Clients not found"
End If
Else 'All clients found
MsgBox "All clients transferred successfully", vbOKOnly, "Transfer Successful"
End If

End Sub
Function GetRange(strFind As String, wsFind As Worksheet, rSource As Range) As Range
Dim rRange As Range
On Error Resume Next

'strFind is the client number, wsFind is the Year sheet and rSource is the range containing
'the client number on the Month tab
'
'If strFind is found, then the function returns its location, otherwise the function returns
'the source cell

Set rRange = wsFind.Columns("B:B").Find(What:=strFind, After:=wsFind.Range("B1"), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If rRange Is Nothing Then
Set GetRange = rSource
Else
Set GetRange = rRange
End If

End Function