Copy and insert 22 lines below and change value

T

Tixevil

New Member
Joined
Jan 3, 2017
Messages
2
Hi I am looking for a solution, once criteria is met ---If Cells(Row, "d") = "1" And Cells(Row, "e") = "6" (change the value on that row)
Then Cells(Row, "f").Value = "U"
copy and insert 22 duplicate lines of the met criteria row and then change the cell .value in column "F" in each of the new rows. i am pretty new to VBA so any help would be much appreciated. i can get it to copy 22 lines its not knowing where to start with the code to change the values of the copies. So for example, i have a questionnaire with 10 Answers, upon meeting criteria in 2 cells, this answer needs copying and inserting 22 times below this answer. Then if the answer in column "F" is 1, i need to change the the new inserted lines (column "F") to 2, 3, 4, n, u, etc. Then i need this to loop through around 2000 questions until its completed it.

I would appreciate you help on this greatly.
Code: 
Public Sub CopyData()
    ' This routing will copy rows based on the quantity to a new sheet.
    Dim rngSinglecell As Range
    Dim rngQuantityCells As Range
    Dim intCount As Integer
Dim LastRow As String
Dim Row As Double


LastRow = Range("D" & Rows.Count).End(xlUp).Row


For Row = 2 To LastRow
Sheets("Sheet1").Activate
' Answer code is "U" answer text is "Redact"
If Cells(Row, "d") = "1" And Cells(Row, "e") = "6" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "1" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "2" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "5" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "6" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "7" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "8" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "9" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "10" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "11" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "12" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "14" Then
Cells(Row, "f").Value = "U"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "16" Then
Cells(Row, "f").Value = "U"
End If
'- answer code is "1" answer text is "-"
If Cells(Row, "d") = "1" And Cells(Row, "e") = "12" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "1" And Cells(Row, "e") = "12" And Cells(Row, "f") = "1" Then
Cells(Row, "g").Value = "-"
End If
If Cells(Row, "d") = "1" And Cells(Row, "e") = "13" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "1" And Cells(Row, "e") = "13" And Cells(Row, "f") = "1" Then
Cells(Row, "g").Value = "-"
End If
If Cells(Row, "d") = "11" And Cells(Row, "e") = "4" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "11" And Cells(Row, "e") = "4" And Cells(Row, "f") = "1" Then
Cells(Row, "g").Value = "-"
End If
If Cells(Row, "d") = "11" And Cells(Row, "e") = "5" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "11" And Cells(Row, "e") = "5" And Cells(Row, "f") = "1" Then
Cells(Row, "g").Value = "-"
End If
' answer code is "100" answer text is "s" note upper case lettering on answer text 
If Cells(Row, "d") = "3" And Cells(Row, "e") = "29" Then
Cells(Row, "f").Value = "100"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "29" And Cells(Row, "f") = "100" Then
Cells(Row, "g").Value = "s"
End If


' Answer code is "5" answer text is "Occupier declianed all Services" note uppercase lettering on answer text as must mach CFRMIS
If Cells(Row, "d") = "3" And Cells(Row, "e") = "18" Then
Cells(Row, "f").Value = "5"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "18" And Cells(Row, "f") = "5" Then
Cells(Row, "g").Value = "s"
End If


' Answer code is "" answer text is "" this should apply blanks to both fields
If Cells(Row, "d") = "3" And Cells(Row, "e") = "3" Then
Cells(Row, "f").Value = ""
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "3" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "4" Then
Cells(Row, "f").Value = ""
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "4" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "15" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "15" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "17" Then
Cells(Row, "f").Value = ""
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "17" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "19" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "19" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "20" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "20" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "01/01/0001"
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "25" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "25" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "0"
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "30" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "30" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "01/01/0001"
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "41" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "41" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "42" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "42" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "43" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "43" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "54" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "54" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "55" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "55" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "56" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "56" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "57" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "57" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "58" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "58" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "59" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "59" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "60" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "60" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "63" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "63" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "64" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "64" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "74" Then
Cells(Row, "f").Value = "n"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "74" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "75" Then
Cells(Row, "f").Value = "7"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "75" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "3" And Cells(Row, "e") = "76" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "3" And Cells(Row, "e") = "76" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


' section 4
If Cells(Row, "d") = "4" And Cells(Row, "e") = "3" Then
Cells(Row, "f").Value = "0"
End If
If Cells(Row, "d") = "4" And Cells(Row, "e") = "3" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "4" And Cells(Row, "e") = "5" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "4" And Cells(Row, "e") = "5" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


' section 5
If Cells(Row, "d") = "5" And Cells(Row, "e") = "6" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "5" And Cells(Row, "e") = "6" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


If Cells(Row, "d") = "5" And Cells(Row, "e") = "9" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "5" And Cells(Row, "e") = "9" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


If Cells(Row, "d") = "5" And Cells(Row, "e") = "11" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "5" And Cells(Row, "e") = "11" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


' section 6




If Cells(Row, "d") = "6" And Cells(Row, "e") = "9" Then
Cells(Row, "f").Value = ""
End If
If Cells(Row, "d") = "6" And Cells(Row, "e") = "9" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If


If Cells(Row, "d") = "6" And Cells(Row, "e") = "10" Then
Cells(Row, "f").Value = "1"
End If
If Cells(Row, "d") = "6" And Cells(Row, "e") = "10" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = "-"
End If


' section 7
If Cells(Row, "d") = "7" And Cells(Row, "e") = "2" Then
Cells(Row, "f").Value = "2"
End If
If Cells(Row, "d") = "7" And Cells(Row, "e") = "2" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If
If Cells(Row, "d") = "7" And Cells(Row, "e") = "1" Then
Cells(Row, "f").Value = "2"
End If
If Cells(Row, "d") = "7" And Cells(Row, "e") = "1" And Cells(Row, "f") = "2" Then
Cells(Row, "g").Value = "No"
End If
'This is to apply redact to all fields that have a u against them
If Cells(Row, "f") = "U" Then
Cells(Row, "G").Value = "Redact"


' duplication event
If Cells(Row, "d") = "6" And Cells(Row, "e") = "8" Then
Cells(Row, "f").Value = ""
End If
If Cells(Row, "d") = "6" And Cells(Row, "e") = "8" And Cells(Row, "f") = "" Then
Cells(Row, "g").Value = ""
End If
End If
Next




    ' Set this for the range where the Quantity column exists. This works only if there are no empty cells
    Set rngQuantityCells = Range("i2", Range("i2").End(xlDown))


    For Each rngSinglecell In rngQuantityCells
        ' Check if this cell actually contains a number
        If IsNumeric(rngSinglecell.Value) Then
            ' Check if the number is greater than 0
            If rngSinglecell.Value > 0 Then
                ' Copy this row as many times as .value
                For intCount = 1 To rngSinglecell.Value
                    ' Copy the row into the next emtpy row in sheet2
                    Range(rngSinglecell.Address).EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
                    ' The above line finds the next empty row.




                Next
            End If
        End If
    Next
 
You must log in or register to reply here.

Similar threads

E
  • Solved
All Unique Combinations from 5 Columns of Data + Customizations - Excel 365
Replies
6
Views
347
Excel Jason
E
neilp
  • Solved
Tweak to VBA code to include last line
Replies
6
Views
95
Joe4
Joe4
I
  • Solved
Listbox on userform to show results in reverse order
2
Replies
16
Views
662
Fuji
F
T
  • Question Question
IF and Match and Input value Issue.
Replies
2
Views
101
timuk26
T
D
  • Solved
Calculating the difference between 2 time values using VBA
Replies
8
Views
262
Micron
M

Forum statistics

Threads
1,226,875
Messages
6,193,455
Members
453,801
Latest member
777nycole

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top