Results 1 to 2 of 2
  1. #1
    New Lounger
    Join Date
    Jul 2014
    Thanked 0 Times in 0 Posts

    Copy & insert rows fom one sheet to another based on data in main sheet

    Hi all,
    I have been trying to solve this problem but canít seem to. I would be grateful if one of you awesome excel users would be able to help.
    I have attached a sample sheet below.
    I have one main sheet called Project Details where I want to input all data.
    In the sub-sheets i.e (Jhon, Adam, Josh,Katy..etc) I only input the headers.
    I want to create a macro so that in the main sheet (Project Details) any Column from C to F that shows Jhonís name, that whole row will be moved into Jhonís sheet.
    For example, Row 7 shows Jhons name is cell C7 so I want the whole of row 7 from (A to O) to copy into Jhons sheet using the macro.
    Similarly, Row 8 shows Jhons name is cell D8 so I want the whole of row 8 from (A to O) to copied into Jhons sheet
    Since Jhons name isnít in row 10, that row will not be moved into Jhons sheet.
    I hope that makes sense and one of you will be able to assist me.
    I am new to VBA, I created a macro but canít seem to make it work.
    All your help will be truly appreciated.
    Attached Files Attached Files

  2. #2
    Super Moderator
    Join Date
    Jan 2001
    Melbourne, Victoria, Australia
    Thanked 295 Times in 267 Posts
    Try the following. Your input sheet was not well organised (in terms of column titles and used range) so I explictly named the address of the region where the names can be found. You will need to modify this if your names list grows or shrinks. I set my code to add the named sheets and it will fail if you already have sheets with those names. Finally, you will need to add a reference to "Microsoft Scripting Runtime" under Tools > References

    Sub MakeSheets()
      Dim d As Object, rng As Range, k, tmp As String
      Dim aSht As Worksheet, sAdd As String
      Dim iRows As Integer, cFound As Range
      sAdd = "C7:F11"
      Set d = CreateObject("scripting.dictionary")
      For Each rng In ActiveWorkbook.Sheets("Project Details").Range(sAdd)
        tmp = Trim(rng.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
      Next rng
      For Each k In d.Keys
        Debug.Print k, d(k)
        Sheets("Project Details").Copy after:=Sheets(Sheets.Count)
        Set aSht = ActiveSheet = k
        With aSht
          Set rng = aSht.Range(sAdd)
          For iRows = rng.Rows.Count To 1 Step -1
            Set cFound = rng.Rows(iRows).Find(k, LookIn:=xlValues)
            If cFound Is Nothing Then rng.Rows(iRows).EntireRow.Delete
          Next iRows
        End With
      Next k
    End Sub
    Andrew Lockton, Chrysalis Design, Melbourne Australia

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts