VBA to insert rows based on cells column in another sheet (same workbook)

[Bond00]

So what I need is to detect if there is anything in Price Work Sheet in E10 to E113
Keep in mind there could be some blank cells mixed in. So it could look like this
E10-E17 in this example:

I need to be able to scan all the cells in this "Price Work Sheet" for any items in this column and on the 2nd Sheet "Finaloutput" Starting below B17 I need it to auto insert rows and copy the text from the other sheet into this sheet starting with B18 (in the B column) as it creates rows for each of them. (I want it to copy the empty space rows as well)

 

[Bond00]

I think the best way to do it maybe would be to loop through finding all the cells <> "" and find the cell row with the last cell with a value in it and then take that row # - 10 to get the # of rows that need to be inserted into "Finaloutput". and then copy over all the values or do that at the same time the rows are inserted.

 

[Bond00]

Played around with it last night testing things
got the worksheet and the range and it stores the values. But this doesn't seem to work to get last row LRow = ws.Range("E10:E50").CurrentRegion.Columns.Count
This works in the cell though to show the last row =SUMPRODUCT(MAX((E10:E50<>"")*ROW(E10:E50)))

I want to loop the array and fill in the values for LRow # of rows and insert that many rows into the other sheet. Im still a long way from that goal.. lol

Public Sub CopyValuesInColumn()
'Application.ScreenUpdating = False

    Dim LRow As Integer
    Dim num As Integer
    Dim i As Integer
    Dim rng As Range
    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = ActiveWorkbook 'or ThisWorkbook
    Set ws = wb.Sheets(1) 'or ("Price Work Sheet") or if its ActiveSheet
    wb.Activate
    ws.Select
    
    Set rng = ws.Range(ws.Cells(10, 5), ws.Cells(50, 5)) 'ex. A10:E50 = .Cells(10, 1), ws.Cells(50, 5)
'Debug.Print Sheet1.Range("A1").Value

    'set num = SUMPRODUCT(MAX((E10:E50<>"")*ROW(E10:E50)))
    LRow = ws.Range("E10:E50").CurrentRegion.Columns.Count 'ThisWorkbook.Sheets("Data").Range("A50").End(xlUp).Row
    Debug.Print LRow
    
    Dim rngCell As Range
    For Each rngCell In rng
        Debug.Print rngCell.Value
    Next rngCell
    
    ' use the Transpose function for a single row or column
    Dim strData As String
    Dim wsf As WorksheetFunction: Set wsf = Application.WorksheetFunction
    strData = Join(wsf.Transpose(rng.Value), ",")
    Debug.Print strData
    
            'select cell (I think the ,1 is column A "1")
      '      Sheet1.Range(Sheet1.Cells(i + 5, 1), Sheet1.Cells(i + 5, 1)).Select
            'do thing

     '       i = i + 1

'Application.ScreenUpdating = True
End Sub

 

[Joe4]

If just doing it once at the end (after data entry in complete), this simple code should do what you want:

Sub MyCopyData()

    Dim lr As Long
    
    Application.ScreenUpdating = False
    
'   Find last row in column E on "Price Work Sheet" with data
    Sheets("Price Work Sheet").Activate
    lr = Cells(Rows.Count, "E").End(xlUp).Row
    
'   Copy/insert range into Finaloutput sheet at cell B17
    Range("E10:E" & lr).Copy
    Sheets("Finaloutput").Activate
    Range("B17").Insert Shift:=xlDown
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True
    
End Sub

 

[Bond00]

Its on the right track but doesnt work, I need it to actually insert rows like this

Cells(i, Col).EntireRow.Insert Shift:=xlDown '1 row

also i'll need to find where to copy over the data as each new row is inserted. or it might be safer to first insert rows and then copy over the data to make sure its in the right order.

this is what happens now, it just shifts down cells in that 1 column not the whole row. and it only shifts down 10 lines when it needs like 26 lines. So I still need to work out how to get the max # of lines to insert as well. and then put it all together into something that works.

 

[Bond00]

this seems to work good now, but how do i make it not have it selected after?
does it look pretty solid? anything to improve or better functions I'm unaware of?

oh and how do i paste without brining over the cell format? I want to paste values only.

Also is it possible to make a cell range dotted lines format after?
like this:

Public Sub CopyValuesInColumn()
Application.ScreenUpdating = False

    Dim i As Long
    Dim LRow As Long
    Dim rng As Range
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws1 As Worksheet: Set ws1 = wb.Sheets(1)
    Dim ws2 As Worksheet: Set ws2 = wb.Sheets("Finaloutput")
   
    ws1.Activate

'   Find last row in column E on "Price Work Sheet" with data
    LRow = ws1.Range("E50").End(xlUp).Row ' =SUMPRODUCT(MAX((E10:E50<>"")*ROW(E10:E50)))
    Debug.Print LRow
   
    Set rng = ws1.Range(ws1.Cells(11, 5), ws1.Cells(LRow, 5))
   
'   Copy/insert range into Finaloutput sheet at cell B18
    For i = 35 To 10 + 1 Step -1
    ws2.Cells(18, 5).EntireRow.Insert Shift:=xlDown '1 row
    Next i
   
    rng.Copy 'Range("E10:E" & LRow).Copy
    ws2.Activate ' Sheets("Finaloutput").Activate
    Cells(18, 2).Select
    ws2.Paste
    Application.CutCopyMode = False

Application.ScreenUpdating = True
End Sub

 

[Bond00]

I think i got it all figured out now.

Public Sub CopyValuesInColumn()

Application.ScreenUpdating = False

    Dim i As Long
    Dim LRow As Long
    Dim rng As Range
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws1 As Worksheet: Set ws1 = wb.Sheets(1)
    Dim ws2 As Worksheet: Set ws2 = wb.Sheets("Finaloutput")
   
    ws1.Activate
'   Find last row in column E on "Price Work Sheet" with data
    LRow = ws1.Range("E113").End(xlUp).Row
   
  If LRow > 10 Then 'needs to use at least 2 rows in quote or glitches when deleting/clearing rows check. Also button not needed then anyway.
    Set rng = ws1.Range(ws1.Cells(11, 4), ws1.Cells(LRow, 7))
   
    ws2.Activate ' Sheets("Finaloutput").Activate
    ' Check if anything in the pasted range and if so delete rows first before pasting new data
    If Cells(18, 2) <> "" Or Cells(19, 2) <> "" Or Cells(20, 2) <> "" Then 'And Cells(LRow + 7, 2) <> "" Then
        Dim LRow2 As Long
        LRow2 = ws2.Range("B121").End(xlUp).Row - 4 'itself + 3 more blank spaces up
        Rows("18:" & LRow2).Select
        Selection.Delete Shift:=xlUp
    End If
   
'   Copy/insert range of rows into Finaloutput sheet at cell B18 (LRow is final row # so it starts there and wrks backwards to 10, the starting row)
    For i = LRow To 10 + 1 Step -1
        ws2.Cells(18, 1).EntireRow.Insert Shift:=xlDown '1 row
    Next i
   
    rng.Copy 'Range("E10:E" & LRow).Copy
    Cells(18, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   
    'Range("A18:D" & LRow + 7).Borders.LineStyle = xlContinuous 'LRow + 7 because main pg is 10 down here starts on 18 and -1 because starting from row 2
    With ws2.Range("A18:D" & LRow + 7).Borders
        .LineStyle = xlDot
        .Weight = xlHairline
    End With
    ' Make inside lines going down lighter gray
    With ws2.Range("A18:D" & LRow + 7).Borders(xlInsideVertical)
        .LineStyle = xlDot
        .ThemeColor = 2
        .TintAndShade = 0.499984740745262
        .Weight = xlHairline
    End With
   
    Application.CutCopyMode = False
    ws2.Select
   
  ElseIf LRow = 10 Then
    ws2.Activate
  End If ' skip the whole thing if not at least 2 lines used in ws1
Application.ScreenUpdating = True

End Sub

 

[Joe4]

Looks like you made a bunch of posts since the last time I was on-line.
I am glad you got things working out the way you need.

One minor tip to help shorten your code and improve efficiency.
Most of the time where you have two lines of code, and one ends with "Select" and the next begins with "Selection", you can combine those together into one line.
It usually isn't necessary to select a range first before working with it. A lot of those blocks like that are due to the very literal nature of the Macro Recorder.
(And having many "Selects" actually slows the code down).

So this:

        Rows("18:" & LRow2).Select
        Selection.Delete Shift:=xlUp

can be reduced to this:

        Rows("18:" & LRow2).Delete Shift:=xlUp

and this:

    Cells(18, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

can be reduced to this:

    Cells(18, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 

[Bond00]

Ah ok thanks for the tips, good to know. And yeah I was able to piece some other things together and get it working right over the weekend lol
thanks again for helping guide it along.

 

[Bond00]

few more questions.
When i set variables for sheet tabs, if i want to not use the typed name and use the vba name is it same as the others?
Dim ws1 As Worksheet: Set ws1 = wb.Sheets(1)
Dim ws2 As Worksheet: Set ws2 = wb.Sheets("Finaloutput")

or does it need to be As a object?
Dim ws1 As Object: Set ws1 = wb.Sheets(Sheet1)
or Set ws1 = wb.Sheets1

looked around on some sites and some had conflicting info.
I basically want to use the vba name if i can to avoid code not working right if I forget and change the tab sheet name someday

**Important part**
Also i forgot in my real doc, i had to use merged cells on the output sheet (ws2). So in my test doc i know you cant copy paste data unless the source and location match the same merged cell count, in this case its 6 cells across merged. So i made a copy of the data on ws1 to the far right side in some hidden columns with this data all lined up so its easy to copy 1 big range of 9 columns for the data.
My issue is i need to paste it as values only. and for the life of me i cant figure out how to do it i keep getting errors.
Run-time error '1004':
Application-defined or object-defined error
ws2.Range("A18").PasteSpecial just doesnt seem to work anyway i use it..
I just want to copy rng.Copy into ws2.Cells(18, 1).Select on down so i guess from "A18:J" & LRow+7
I tried just selecting A18 and pasting normal and that works fine but I need to paste values only.

 

[Bond00]

For the pasting values only, i came across this: ws2.Range("A18:J" & LRow + 7).Value = rng.Value
So it didnt use the copy paste function and worked good, unless theres a better way let me know.

Also 1 last issue i came across on this.
On Col A i need to count down but only where there is a value > 0 in column H.
how can i do that? is there some function I can use to do this in that column A?