Filling a copy/pasted adjacent dynamic range with sequential values

A

ag17

New Member
Joined
Sep 22, 2022
Messages
6
Office Version
  1. 365
Platform
  1. Windows
I have a sheet that logs blocks of ammunition for endurance testing which is done in layers. The number of ammo specs per layer isn't always the same so I have it set up as a dynamic range and a VBA code to pull those values (posted below). Additionally, I want to fill column A with "Layer 1" next to the first block of ammo specs, "Layer 2" next to the second block, and so on. The number of layers is called from C62 in the Test Ammo sheet, as are the individual ammo specs. You can see on the "Test Ammo" sheet where I specify that I want 10 layers and you can see how the data is laid out. The code for the endurance sheet goes in and sorts the table by eliminating blanks in the qty values. Is there an easy way to write in a code that fills the A column with the respective layers by the blocks of ammo for each layer?

prt endurance.PNG
test ammo.PNG



Sub sortcopypastaPRT()
Worksheets("PRT Endurance").Range("B6:D500").ClearContents

Sheets("Test Ammo").Select
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=14, Criteria1:= _
"<>"

Sheets("Test Ammo").Range("N64:N113").Copy
Sheets("PRT Endurance").Range("D6").PasteSpecial Paste:=xlPasteValues

Sheets("Test Ammo").Range("O64:O113").Copy
Sheets("PRT Endurance").Range("B6").PasteSpecial Paste:=xlPasteValues

Sheets("Test Ammo").Range("C64:C113").Copy
Sheets("PRT Endurance").Range("C6").PasteSpecial Paste:=xlPasteValues

Sheets("PRT Endurance").Activate

Dim rngSrc As Range
Set rngSrc = Sheets("PRT Endurance").Range("B6", Range("D" & Rows.Count).End(xlUp))
rngSrc.Copy

Dim x As Long
For x = 2 To Sheets("Test Ammo").Range("C62")
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row
rngSrc.Offset((lr) - 4).PasteSpecial xlPasteValues
Next x

Dim x As Long
For x = 2 To Sheets("Test Ammo").Range("C62")
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row
rngSrc.Offset((lr) - 4).PasteSpecial xlPasteValues
Next x




Sheets("PRT Endurance").Activate

Range("B6:D500").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

MsgBox "Please select the respective layer values from the adjacent drop downs."

End Sub
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
Sort by date Sort by votes
It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your "Test Ammo" and "PRT Endurance" sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
mumps said:
It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your "Test Ammo" and "PRT Endurance" sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
Click to expand...
I'm hesitant to drop in the file because it's a spreadsheet I'm making for work. I can start working on deleting a lot of the extra sheets to make it more appropriate for posting though.
 
Upvote 0
work excel sheet.xlsm

here's a link to the sheet. I dropped it in google drive. You'll have to download it to view the code but i tested it and it works when you download it.
 
Upvote 0
Click here to download your file. I have tidied up your code a bit and added code to fill in column A. I have also deleted all the extra unused rows and columns in your sheets which made your file very big. It is now only 91 kilobytes in size instead of almost 15 megabytes. This should speed saving and opening the file.
VBA Code: 
Sub sortcopypastaPRT()
    Application.ScreenUpdating = False
    Dim rngSrc As Range, x As Long, lr As Long
    Worksheets("PRT Endurance").Range("B6:D500").ClearContents
    With Sheets("Test Ammo")
        .ListObjects("Table1").Range.AutoFilter Field:=14, Criteria1:="<>"
        .Range("N64:N113").Copy
        Sheets("PRT Endurance").Range("D6").PasteSpecial Paste:=xlPasteValues
        .Range("O64:O113").Copy
        Sheets("PRT Endurance").Range("B6").PasteSpecial Paste:=xlPasteValues
        .Range("C64:C113").Copy
        Sheets("PRT Endurance").Range("C6").PasteSpecial Paste:=xlPasteValues
    End With
    With Sheets("PRT Endurance")
        Set rngSrc = .Range("B6", .Range("D" & .Rows.Count).End(xlUp))
        rngSrc.Copy
        For x = 2 To Sheets("Test Ammo").Range("C62")
            lr = .Range("B" & Rows.Count).End(xlUp).Row
            rngSrc.Offset((lr) - 4).PasteSpecial xlPasteValues
        Next x
        With .Range("B6:D500")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With
        With .Range("B6", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
            For i = 1 To .Areas.Count
                frow = .Areas(i).Cells(1).Row
                lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                With Sheets("PRT Endurance").Range("A" & frow)
                    .Value = "1"
                    .AutoFill Destination:=Sheets("PRT Endurance").Range("A" & frow).Resize(lRow - frow + 1), Type:=xlFillSeries
                End With
            Next i
        End With
    End With
    Application.ScreenUpdating = True
    MsgBox "Please select the respective layer values from the adjacent drop downs."
End Sub
 
Upvote 0
mumps said:
Click here to download your file. I have tidied up your code a bit and added code to fill in column A. I have also deleted all the extra unused rows and columns in your sheets which made your file very big. It is now only 91 kilobytes in size instead of almost 15 megabytes. This should speed saving and opening the file.
VBA Code: 
Sub sortcopypastaPRT()
    Application.ScreenUpdating = False
    Dim rngSrc As Range, x As Long, lr As Long
    Worksheets("PRT Endurance").Range("B6:D500").ClearContents
    With Sheets("Test Ammo")
        .ListObjects("Table1").Range.AutoFilter Field:=14, Criteria1:="<>"
        .Range("N64:N113").Copy
        Sheets("PRT Endurance").Range("D6").PasteSpecial Paste:=xlPasteValues
        .Range("O64:O113").Copy
        Sheets("PRT Endurance").Range("B6").PasteSpecial Paste:=xlPasteValues
        .Range("C64:C113").Copy
        Sheets("PRT Endurance").Range("C6").PasteSpecial Paste:=xlPasteValues
    End With
    With Sheets("PRT Endurance")
        Set rngSrc = .Range("B6", .Range("D" & .Rows.Count).End(xlUp))
        rngSrc.Copy
        For x = 2 To Sheets("Test Ammo").Range("C62")
            lr = .Range("B" & Rows.Count).End(xlUp).Row
            rngSrc.Offset((lr) - 4).PasteSpecial xlPasteValues
        Next x
        With .Range("B6:D500")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With
        With .Range("B6", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
            For i = 1 To .Areas.Count
                frow = .Areas(i).Cells(1).Row
                lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                With Sheets("PRT Endurance").Range("A" & frow)
                    .Value = "1"
                    .AutoFill Destination:=Sheets("PRT Endurance").Range("A" & frow).Resize(lRow - frow + 1), Type:=xlFillSeries
                End With
            Next i
        End With
    End With
    Application.ScreenUpdating = True
    MsgBox "Please select the respective layer values from the adjacent drop downs."
End Sub
Click to expand...
Thank you for the reply! It's good to see cleaner versions of my code, helps me learn to be more concise in my coding. The Layer Values aren't quite right. They're populating in the right places but I want the entire first block to say "Layer 1" and then the entire 2nd block to say "Layer 2" instead of layer 1 next to all of the X22LR specs, "Layer 2" by all of the X22LRPP1 cells, and so on. I attached a screenshot of what i'm looking for but i had to manually do that. I am going to try to build off your code and get something figured out.
 

Attachments

  • Capture.PNG
    Capture.PNG
    29.5 KB · Views: 8
Upvote 0
My approach for it was to write in a count function (we'll call the variable A) on that first ammo block then write a loop code to write "layer X" "A" amount of time with x being a variable starting at 1 and increasing to X with a 1 row offset. I'm just not sure how to yet.
 
Upvote 0
Try:
VBA Code: 
Sub sortcopypastaPRT()
    Application.ScreenUpdating = False
    Dim rngSrc As Range, x As Long, lr As Long
    Worksheets("PRT Endurance").Range("B6:D500").ClearContents
    With Sheets("Test Ammo")
        .ListObjects("Table1").Range.AutoFilter Field:=14, Criteria1:="<>"
        .Range("N64:N113").Copy
        Sheets("PRT Endurance").Range("D6").PasteSpecial Paste:=xlPasteValues
        .Range("O64:O113").Copy
        Sheets("PRT Endurance").Range("B6").PasteSpecial Paste:=xlPasteValues
        .Range("C64:C113").Copy
        Sheets("PRT Endurance").Range("C6").PasteSpecial Paste:=xlPasteValues
    End With
    With Sheets("PRT Endurance")
        Set rngSrc = .Range("B6", .Range("D" & .Rows.Count).End(xlUp))
        rngSrc.Copy
        For x = 2 To Sheets("Test Ammo").Range("C62")
            lr = .Range("B" & Rows.Count).End(xlUp).Row
            rngSrc.Offset((lr) - 4).PasteSpecial xlPasteValues
        Next x
        With .Range("B6:D500")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With
        With .Range("B6", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
            For i = 1 To .Areas.Count
                frow = .Areas(i).Cells(1).Row
                lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                Sheets("PRT Endurance").Range("A" & frow).Resize(lRow - frow + 1) = "Layer " & i
            Next i
        End With
    End With
    Application.ScreenUpdating = True
    MsgBox "Please select the respective layer values from the adjacent drop downs."
End Sub
 
Upvote 0
Fantastic! that worked wonderfully. Can you break the section of code that fills the layer values down for me?
 
Upvote 0
To understand, you need to know how "areas" works in Excel. An "area" is a range made up of continuous rows separated by a blank row. In your case, there are 11 areas. This was based on column B before the layer values are filled. The variable "i" loops through the areas and sets the first and last rows in each area.
VBA Code: 
Sheets("PRT Endurance").Range("A" & frow).Resize(lRow - frow + 1) = "Layer " & i
This line of code resizes the first cell of each area in column A to the number of rows in each area and inserts the layer values, so if i=1 (first area), the layer value will be "Layer 1". etc. I hope this makes sense.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Keebler
  • Solved
new project: copy range without empty or blank rows
5 6 7
Replies
68
Views
1K
Keebler
Keebler
I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
173
ItalianPlatinum
I
C
  • Question
Named ranges from multiple sections of cells copy paste not working
Replies
6
Views
71
Alex Blakenburg
A
B
  • Question
VBA code to cut and paste multiple filtered rows based on multiple criteria
Replies
2
Views
463
Alex Blakenburg
A
D
  • Solved
Paste values code
Replies
3
Views
373
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,214,653
Messages
6,120,751
Members
448,989
Latest member
mariah3

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