Results 1 to 2 of 2
2014-07-24, 03:23 #1
- Join Date
- Jul 2014
- Thanked 0 Times in 0 Posts
Copy & insert rows fom one sheet to another based on data in main sheet
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.
2014-07-25, 03:31 #2
- Join Date
- Jan 2001
- Melbourne, Victoria, Australia
- Thanked 264 Times in 242 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 aSht.name = 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 SubAndrew Lockton, Chrysalis Design, Melbourne Australia