Copy Data to Another Excel Worksheet Based on Criteria Using VBA

[FrancisM]

I am trying to write a macro to have excel copy certain data from one worksheet to another, if certain criteria is met. Both worksheets are in the same workbook. A worksheet named "Referrals" & in column B are names, in column M is "VR". The second worksheet is named "VOC_ASST". I am trying to copy the names from "Referrals" the master sheet to "VOC_ASST" the recipient worksheet, if "VR" is found in column M. Ideally, the copying of the names would occur in such a way that the names would populate the next available space, & there is no duplication of names unless the name is entered a second time on the master sheet. I have been able to only get it to copy, from the cell location on the master sheet (Referrals) to the same cell location on the recipient sheet (VOC_ASST).
Attached is the current code.

Code: Select all

Sub myVOC_ASST()
 Dim LastRow As Integer
 Dim i As Integer
 Dim erow As Integer
 Worksheets("Referrals").Select
 erow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
 For i = 2 To erow
 Worksheets("Referrals").Select
 If Cells(i, 13) = "VR" Then
 Cells(i, 2).Select
 Selection.Copy
 Worksheets("VOC_ASST").Select
 erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 1).Row
 ActiveSheet.Cells(i, "A").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Skipblanks:=True, Transpose:=False
 Application.CutCopyMode = False
 End If
 Next i
 ActiveWorkbook.Save
 Sheets("VOC_ASST").Select
 Rows("2:2").Select
 Range(Selection, Selection.End(xlDown)).Select
 Selection.ClearContents
 Range("A1").Select
 Sheets("Referrals").Select
 End Sub

I have been working with people from 'excel-l@Groups.ITtoolbox.com', but because of my limited (non-formal training)knowledge of VBA, I am having limited success. Could you point me in the right direction. Thank you for your assistance

[charles]

Hi,

Can you attach a copy of the workbook?

[FrancisM]

I just noticed that in the sanitized version, it does not copy any names, however in the live copy it, does copy the names.

[charles]

Thanks. I'll take a look as soon as my PC stops acting up.
Also another member may pick up on this.

[FrancisM]

As stated in the initial post, I was working with 'excel-l@Groups.ITtoolbox.com. Some of the lines of code I found on my own. Some of the other lines I got from the above group.

[charles]

Hi,

Sorry I can not open the file receive error "Object" not loaded on this machine. So it appears that I can not help.
Perhaps another member can assist you.

[FrancisM]

I found the following code on PCWorld Press F1, and made the appropriate changes.
This code activates a button .

Code: Select all

Private Sub CommandButton15_Click()
VOC_ASST
End Sub

This code is for a module that does the actual copy.

Code: Select all

Sub VOC_ASST()
Dim TargetSht As Worksheet, SourceSht As Worksheet, SourceCol As Integer, SourceCells As Range

'If an error occurs skip code to the Err-Hanlder line and the display the error message.
On Error GoTo Err_Handler

'This is the sheet where your copy information from.
Set SourceSht = ThisWorkbook.Sheets("Referrals")

'Name of the sheet where data is to be copied to.
Set TargetSht = ThisWorkbook.Sheets("VOC_ASST")

'This is the cells you will copy data from. This is targeting cells B1 to the last used cell in column B
Set SourceCells = SourceSht.Range("B1:B" & SourceSht.Range("B65536").End(xlUp).Row)

'This is finding the next column available in the target sheet. It assumes dates will be in row 1 and data in row 2 down
If TargetSht.Range("A1").Value = "" Then
    'Cell A1 is blank so the column to put data in will be column #1 (ie A)
    SourceCol = 1
ElseIf TargetSht.Range("IV1").Value <> "" Then
    'Cell IV1 has something in it so we have reached the maximum number of columns we can use in this sheet.
    'Dont paste the data but advise the user.
    MsgBox "There are no more columns available in the sheet " & TargetSht.Name, vbCritical, "No More Data Can Be Copied"
    'stop the macro at this point
    Exit Sub
Else
    'cell A1 does have data and we havent reached the last column yet so find the next available column
    SourceCol = TargetSht.Range("IV1").End(xlToLeft).Column + 1
End If

'We can now start copying data. This will copy the cells in column B from the source sheet to row 2+ in the target sheet
SourceCells.Copy TargetSht.Cells(2, SourceCol)

'Advise the user that the process was successful
MsgBox "Data copied successfully!", vbInformation, "Process Complete"

Exit Sub 'This is to stop the procedure so we dont display the error message every time.
Err_Handler:

It works, but it copies the entire column. I am not certain where I should place the code to filter for "VR" in column M,. Also I don't want to have duplicates, unless the name is entered a second time.

[NoSparks]

Does this do whatever it is you're trying to do?

Code: Select all

Sub myVOC_ASST()
    Dim i As Integer
    Dim erow As Integer
    Dim WriteRow As Integer
    Dim srcWS As Worksheet      'source
    Dim destWS As Worksheet     'destination
   
Set srcWS = ThisWorkbook.Worksheets("Referrals")
Set destWS = ThisWorkbook.Worksheets("VOC_ASST")

WriteRow = destWS.Range("A2002").End(xlUp).Row + 1
' A2002 because you have a formula on row 2003

If WriteRow < 3 Then WriteRow = 3
'start copy at row 3 because formulas start at row 3

With srcWS
    erow = srcWS.Range("B325").End(xlUp).Row
    ' its B325 because that's the end of your data and
    ' you have other "stuff" below that

    For i = 2 To erow
        If .Cells(i, 13) = "VR" Then
            destWS.Cells(WriteRow, 1).Value = .Cells(i, 2).Value
            WriteRow = WriteRow + 1
        End If
    Next i
End With

ActiveWorkbook.Save

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' don't know what this is all about
' suspect something while the macro recorder was on
'    Sheets("VOC_ASST").Select
'    Rows("2:2").Select
'    Range(Selection, Selection.End(xlDown)).Select
'    Selection.ClearContents
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

'Position the active cell
destWS.Select
Range("A1").Select

srcWS.Select

End Sub


[FrancisM]

I left out a piece of code.

Code: Select all

Select all
MsgBox "The following error occured:" & vbLf & "Error #: " & Err.Number & vbLf & "Description: " & Err.Description, _
        vbCritical, "An Error Has Occured", Err.HelpFile, Err.HelpContext


End Sub

[FrancisM]

To avoid any confusion, I am reposting the code.

Code: Select all

Sub VOC_ASST()
Dim TargetSht As Worksheet, SourceSht As Worksheet, SourceCol As Integer, SourceCells As Range

'If an error occurs skip code to the Err-Hanlder line and the display the error message.
On Error GoTo Err_Handler

'This is the sheet where your copy information from.
Set SourceSht = ThisWorkbook.Sheets("Referrals")

'Name of the sheet where data is to be copied to.
Set TargetSht = ThisWorkbook.Sheets("VOC_ASST")

'This is the cells you will copy data from. This is targeting cells B1 to the last used cell in column B
Set SourceCells = SourceSht.Range("B1:B" & SourceSht.Range("B65536").End(xlUp).Row)

'This is finding the next column available in the target sheet. It assumes dates will be in row 1 and data in row 2 down
If TargetSht.Range("A1").Value = "" Then
    'Cell A1 is blank so the column to put data in will be column #1 (ie A)
    SourceCol = 1
ElseIf TargetSht.Range("IV1").Value <> "" Then
    'Cell IV1 has something in it so we have reached the maximum number of columns we can use in this sheet.
    'Dont paste the data but advise the user.
    MsgBox "There are no more columns available in the sheet " & TargetSht.Name, vbCritical, "No More Data Can Be Copied"
    'stop the macro at this point
    Exit Sub
Else
    'cell A1 does have data and we havent reached the last column yet so find the next available column
    SourceCol = TargetSht.Range("IV1").End(xlToLeft).Column + 1
End If

'We can now start copying data. This will copy the cells in column B from the source sheet to row 2+ in the target sheet
SourceCells.Copy TargetSht.Cells(2, SourceCol)

'Advise the user that the process was successful
MsgBox "Data copied successfully!", vbInformation, "Process Complete"

Exit Sub 'This is to stop the procedure so we dont display the error message every time.
Err_Handler:
MsgBox "The following error occured:" & vbLf & "Error #: " & Err.Number & vbLf & "Description: " & Err.Description, _
        vbCritical, "An Error Has Occured", Err.HelpFile, Err.HelpContext


End Sub