If, then, copy programming

**dodom75** · 07-07-2008, 12:04 PM

I have attached a worksheet as my example.

I have been trying to build code and I am a newbie when it comes to this.

I have a sheet that is user entered (Criteria). I need to build a macro/code that says if they choose "Yes" to any of the Products on the criteria sheet, then copy all rows that have an X in them that are in the corresponding column on the Master Template. To make it even more complicated I only want to copy 4 of the columns (ID, Task, Share with Client and Accountable).

I know if they choose multiple columns then I could have duplicate rows, but once all the rows are copied I was going to build a remove duplicates macro. However, if there is anyway of preventing duplicates with the original I am open for any assistance.

**rylo** · 07-07-2008, 08:53 PM

Hi

See how this goes. I've had to update your defined name YN as it was referencing a sheet that no longer exists in the workbook.

rylo

**dodom75** · 07-08-2008, 02:34 PM

Hi Rylo,

Thank you so much. I have attached the full version of the form. The information you sent me worked perfectly.

So I have a few more questions, if you don't mind answering? I am taking some classes in August so hopefully I will understand this by then.

How can we bring over the title rows (yellow lines above the sections) and within the larger sections there are break lines. Is there a way to bind the macro to say for section if Row 3-14 is copied/selected automatically pull row 2 and the formatting from the master template?

Then how do we get it to sort in the correct order?

Again, thank you so much for the other information, I sincerely appreciate it.

**rylo** · 07-08-2008, 06:46 PM

Danielle

Try this.

Private Sub CommandButton1_Click()
  Dim OutSH As Worksheet, TemplateSH As Worksheet, ce As Variant
  Dim DataCol As Integer, OutRow As Long, i As Long
  Dim arr As Variant
  Set OutSH = Sheets("Internal Project Plan")
  Set TemplateSH = Sheets("Master Template")
  
  For Each ce In Range("B13:B70")
    If ce = "Yes" Then
      DataCol = WorksheetFunction.Match(ce.Offset(0, -1).Value, TemplateSH.Rows("1:1"), 0)
      With TemplateSH
        For i = 2 To 650
          If .Cells(i, DataCol).Value = "x" Then
          'check to see if it already exists and only proceed if it does not
            If WorksheetFunction.CountIf(OutSH.Range("A:A"), TemplateSH.Cells(i, 1).Value) = 0 Then
              OutRow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
              OutSH.Cells(OutRow, 1).Value = .Cells(i, 1).Value
              OutSH.Cells(OutRow, 2).Value = .Cells(i, 4).Value
              OutSH.Cells(OutRow, 3).Value = .Cells(i, 10).Value
              OutSH.Cells(OutRow, 4).Value = .Cells(i, 5).Value
              OutSH.Cells(OutRow, 10).Value = .Cells(i, 63).Value
            End If
          End If
        Next i
      End With
    End If
  Next ce
  Application.StatusBar = "Transferring Headings"
  arr = Array(2, 15, 77, 87, 461, 507, 534, 553, 582)
  With TemplateSH
    For i = LBound(arr) To UBound(arr)
      OutRow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      .Cells(arr(i), 1).Copy Destination:=OutSH.Cells(OutRow, 1)
      OutSH.Cells(OutRow, 1).Value = .Cells(arr(i), 1).Value
      .Cells(arr(i), 4).Copy Destination:=OutSH.Cells(OutRow, 2)
      OutSH.Cells(OutRow, 2).Value = .Cells(arr(i), 4).Value
      .Cells(arr(i), 10).Copy Destination:=OutSH.Cells(OutRow, 3)
      OutSH.Cells(OutRow, 3).Value = .Cells(arr(i), 10).Value
      .Cells(arr(i), 5).Copy Destination:=OutSH.Cells(OutRow, 4)
      OutSH.Cells(OutRow, 4).Value = .Cells(arr(i), 5).Value
      .Cells(arr(i), 63).Copy Destination:=OutSH.Cells(OutRow, 10)
      OutSH.Cells(OutRow, 10).Value = .Cells(arr(i), 63).Value
    Next i
  End With
  'sort output data
  Application.StatusBar = "Sorting Output"
  With OutSH
    .Range("A6:J" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort key1:=.Range("A6"), order1:=xlAscending, header:=xlYes
  End With
  
  Application.StatusBar = False
End Sub

In Master Template!I461, you have an x in your heading row. Running this code on your latest example file will bring this heading over 2 times. I'm guessing that this X shouldn't be in that cell.

rylo

**dodom75** · 07-09-2008, 05:06 PM

Hi Rylo,

It worked perfectly, thank you. However, is there anyway to make that formatting copy for column E, F, G, H, I? it only copys to the cells we copy over. Or, is there a way to make E, F, G, H, I just copy the color from column D?

Thanks again for all your help. I really appreciate it. Have a good evening.

**rylo** · 07-09-2008, 06:32 PM

Danielle

Change the with block at the end to be

With OutSH
    .Range("A6:J" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort key1:=.Range("A6"), order1:=xlAscending, header:=xlYes
    .Range("E7:H" & .Cells(Rows.Count, 1).End(xlUp).Row).Interior.ColorIndex = .Range("B7").Interior.ColorIndex
  End With

rylo

**dodom75** · 07-10-2008, 01:10 PM

Hi Rylo,

Thank you again. When I ran the code you posted it highlighted row e-h in yellow instead of copying the formating of column B. So I tried changing the range reference to("b" & Range("b60000") code below, but now I get an error run-time error 1004. Any ideas?

.Range("E7:H" & .Cells(Rows.Count, 1).End(xlUp).Row).Interior.ColorIndex = .Range("B" & Range("B60000").Interior.ColorIndex)

**dodom75** · 07-10-2008, 03:22 PM

I was able to get this to work as a separate macro below, but when I try to put them together it is not copying all the way down.

Sub cols()
Dim i As Long
With ActiveSheet
    For i = 7 To Range("B" & Rows.Count).End(xlUp).Row
        .Range("E" & i & ":I" & i).Interior.ColorIndex = .Range("B" & i).Interior.ColorIndex
    Next i
End With
End Sub

**VBA Noob** · 07-10-2008, 03:55 PM

dodom75,

You have being asked before I believe to read the forum rules. If you had read them (Forum rules below) you would know cross posting without providing the link is not permitted

Please add the link now if you wish to continue posting here

VBA Noob