Find and copy cells from top to bottom

[nowitzki2005]

I am trying to write a macro that finds individual Agent IDs(made up of three digits and each in their own cell) in column D and copies it, then pastes that individual Agent ID into a different sheet. I have already written the macro to activate the sheet with the list of Agent IDs and then activate the corresponding sheet to that agent. But I cannot get it to loop through the column of IDs moving on to the next Agent ID. I can just get the macro to copy the first Agent ID and then paste it to all the other sheets that have been created with the same ID that I got it to copy in the beginning. This is what I have so far. Thanks in advance for any help!

Graham




Sub CopyAgentInfoToExcelSheet()
Dim strSource As String
Dim WKBSource As Workbook
Dim iCount As Integer
Dim i As Integer

strSource = ActiveWorkbook.Name
Set WKBSource = Workbooks(strSource)
strPath = WKBSource.Path
iCount = WKBSource.Sheets.Count
strFileName = ""
For i = Range("A65536").End(xlUp).Row To 2 Step -1
'look every agent, create an equal amount

If Err.Number <> 0 Then
MsgBox Err.Number & " " & Err.Description
Err.Clear
Else

WKBSource.Activate
Sheets("Activity Template").Activate
Range("A1:J25").Select
Selection.Copy
'Copy the entire sheet titled Activity Template (This is just a copy, it doesn't actually paste anything yet)
Dim ActNm As String

With ActiveWorkbook.Sheets
.Add After:=Worksheets(Worksheets.Count)
End With
ActNm = ActiveSheet.Name
On Error Resume Next
ActiveSheet.Name = InputBox("Please Enter Agent ID")
'Enter an agent ID to create a new sheet with that agent's ID
Noname: If Err.Number = 1004 Then ActiveSheet.Name = InputBox("Agent ID Already Entered. Please Enter Next Agent ID.")
If ActiveSheet.Name = ActNm Then GoTo Noname
On Error GoTo 0
'if you reenter the same Agent ID twice, it will see that as an error and ask for the next Agent ID

WKBSource.Activate
Range("a1").Select
ActiveSheet.Paste
'after the sheet has been created, it will paste the activity template into that newly created sheet

WKBSource.Activate
Sheets("Agents").Activate
Range("d1").Select
Selection.Copy
'copy the first Agent's ID number

Sheets(InputBox("Please Enter Agent ID to Transfer Data.")).Activate
Range("e1").Select
ActiveSheet.Paste
'A message box will pop up and ask for the ID to transfer the data to and then will paste the Agent ID
End If

Next i
End Sub

 

[pbornemeier]

Welcome to the Board!

Your code and your description seem to conflict in a few areas. Please check out this code and see if it does what you want.

Option Explicit
'Assume one workbook with a worksheet named Agents that contains a list
'   of ID numbers starting in D2 and continuing down
'That workbook also contains a worksheet named Activity Template
'For each unique ID in Agents!Column D, copy "A1:J25" of the Activity
'   Template to a new worksheet and put the agent ID in E1 of that worksheet
 
Sub CopyAgentInfoToExcelSheet2()
 
    Dim iFoundWorksheets As Integer
    Dim lX As Long
    Dim lY As Long
    Dim sID As String
    Dim lLastAgentRow As Long
    'Verify correct workbook is active
    iFoundWorksheets = 0
    For lX = 1 To ActiveWorkbook.Worksheets.Count
        If ActiveWorkbook.Worksheets(lX).Name = "Agents" Then iFoundWorksheets = iFoundWorksheets + 1
        If ActiveWorkbook.Worksheets(lX).Name = "Activity Template" Then iFoundWorksheets = iFoundWorksheets + 1
        If iFoundWorksheets = 2 Then Exit For
    Next
 
    If iFoundWorksheets <> 2 Then
        MsgBox "Ensure the correct workbook is active prior to running this procedure."
        GoTo End_Sub
    End If
 
    With Worksheets("Agents")
        lLastAgentRow = .Cells(.Rows.Count, 4).End(xlUp).Row
        For lX = 2 To lLastAgentRow
            sID = .Cells(lX, 4).Value
            iFoundWorksheets = 0
            For lY = 1 To ActiveWorkbook.Worksheets.Count
                If ActiveWorkbook.Worksheets(lY).Name = sID Then
                    iFoundWorksheets = 1
                    Exit For
                End If
            Next
            If iFoundWorksheets = 0 Then
                'Add new worksheet
                Worksheets.Add(after:=Sheets(Sheets.Count)).Name = sID
                Worksheets("Activity Template").Range("A1:J25").Copy Destination:=Worksheets(sID).Range("A1")
                ActiveSheet.Range("E1").Value = sID
            End If
        Next
    End With
 
End_Sub:
 
End Sub

 

[nowitzki2005]

Thank you so much, that works perfectly!