VBA copy and paste to new sheet based on number of rows

[wolthers]

Hi, I am making a workbook to log all data based on coffee roast profiles sold.

Sales sheet has the following which I want to copy to log sheet.
B2 = sales ID
B4 = name (either company or person)

Then I can have data from D11 all the way to F20, and that's where I am finding difficulties, I can copy and paste D11:F11 but if I have more than one row then I will only have data on the first row on the log sheet.

D11	E11	F11
Light	Whole	1,250 g
Medium	Whole	2,500 g
Dark	Whole	2,500 g
Medium	Ground	750 g

log sheet is as follows:

(A)Day	(B)Order Nr	(C)Client	(D)Seller	(E)Roast	(F)Prep	(G)Quantity
16-06-20	SBC 00001	Baker	Dan	Light	Whole	1250
				Medium	Whole	2500
				Dark	Whole	2500
				Medium	Ground	750
16-06-20	SBC 00002	Lawyer	Tom	Light	Whole	1250
				Medium	Whole	2500
				Dark	Whole	2500
				Medium	Ground	750
16-06-20	SBC 00003	Dentist	Joe	Light	Whole	1250
				Medium	Whole	2500
				Dark	Whole	2500
				Medium	Ground	750

should look as follows:

(A)Day	(B)Order Nr	(C)Client	(D)Seller	(E)Roast	(F)Prep	(G)Quantity
16-06-20	SBC 00001	Baker	Dan	Light	Whole	1250
16-06-20	SBC 00001	Baker	Dan	Medium	Whole	2500
16-06-20	SBC 00001	Baker	Dan	Dark	Whole	2500
16-06-20	SBC 00001	Baker	Dan	Medium	Ground	750
16-06-20	SBC 00001	Lawyer	Tom	Light	Whole	1250
16-06-20	SBC 00001	Lawyer	Tom	Medium	Whole	2500
16-06-20	SBC 00001	Lawyer	Tom	Dark	Whole	2500
16-06-20	SBC 00001	Lawyer	Tom	Medium	Ground	750
16-06-20	SBC 00001	Dentist	Joe	Light	Whole	1250
16-06-20	SBC 00001	Dentist	Joe	Medium	Whole	2500
16-06-20	SBC 00001	Dentist	Joe	Dark	Whole	2500
16-06-20	SBC 00001	Dentist	Joe	Medium	Ground	750

my VBA macro:

Sub insert()

Dim ms As Worksheet, NR
Set ms = Sheets("log")
   With Sheets("sales")

       NR = ms.Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
       

       ms.Range("A" & NR) = Date
       
           .Range("B2").Resize(1).Copy  'sale nr
       ms.Range("B" & NR).PasteSpecial xlValues
       
           .Range("B4").Resize(1).Copy  'client
       ms.Range("C" & NR).PasteSpecial xlValues
       
       myValue = InputBox("Quem vendeu") 'broker
       ms.Range("D" & NR).Value = myValue
       
'A B C and D should repeat the paste by the amount of rows between B11 and B20 with data

       .Range("d11:f11").Resize(10).Copy   'order
       ms.Range("E" & NR).PasteSpecial xlValues, Transpose:=False
    
    
   End With
  
End Sub

 

[braindiesel]

Sub dittoIt()
'
' dittoIt Macro
'

'
    Range("A1:G12").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Application.CutCopyMode = False
    Selection.FormulaR1C1 = "=R[-1]C"
End Sub

This will fill in the blanks
and then you may want to copy and paste as values

 

[Joe4]

You can fill in the missing values in your table using the methods described here (both manual and VBA options):

Fill Blank Cells in Excel Column

In Excel, fill blank cells with values from cells above, manually or programmatically

www.contextures.com

 

[wolthers]

Thanks Joe4, these are a bit complex for me, but I was able to get one column to fill up, do you know how I can make the below work for the first 4 columns?

Sub FillColBlanks_Offset()
'by Rick Rothstein  2009-10-24
'fill blank cells in column with value above
'https://www.contextures.com/xlDataEntry02.html

  Dim Area As Range, LastRow As Long
  On Error Resume Next
  LastRow = Cells.Find(What:="*", SearchOrder:=xlRows, _
               SearchDirection:=xlPrevious, _
               LookIn:=xlFormulas).Row
  For Each Area  ms.Range("A1").EntireColumn(1).Resize(LastRow). _
               SpecialCells(xlCellTypeBlanks).Areas
    Area.Value = Area(1).Offset(-1).Value
  Next
End Sub

I tried messing with EntireColumn(4)
Area(1 through 4) will just choose which column based on column A.

 

[Joe4]

Here is some code that is based on braindiesel's method, but is a little more dynamic, and converts everything to values:

Sub MyFillMacro()

    Dim rng As Range
    
'   Set range to apply this to
    Set rng = Range("A1").CurrentRegion

'   Fill in blanks with formulas
    rng.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = "=R[-1]C"
    
'   Turn formulas into values
    rng.Value = rng.Value

End Sub

Note that I am assuming that your headers start in cell A1.

 

[wolthers]

Thanks Joe,

Also tried this code below earlier today which worked.

'Activate target worksheet.
Worksheets(5).Activate
'Find the last row with data.
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For x = 1 To LastRow
    'Don't do anything until the first time a non-blank cell in column A is reached.
    If Cells(x, 1) <> "" Then
        DataStarted = True
    'Then if there are blanks in the row, fill them in with the data from the cell above.
    ElseIf DataStarted Then
        LastCol = Rows(x - 1).Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        With Range(Cells(x, 1), Cells(x, LastCol))
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
            .Value = .Value
        End With
    End If
Next x

 

[Joe4]

Just bear in mind that loops are rather slow, so if there are others ways of doing it, your code will be faster if you avoid looping.
The way I did it does not use any loops (and the code is a bit shorter too!).

 

[wolthers]

Thanks Joe, I have tested yours out and it's indeed faster, but it also copies down to 10 rows below, because of this other line:

 .Range("d11:f11").Resize(10).Copy

It will only copy values if there are, the nr. of rows may vary depending on the size of the order.
Example below where I had 4 rows of items, it went all the down to 10 lines.

date	sales id	buyer	seller	roast	prep	quantity
17-06-20	SBC 00017	Baker	Dan	Light	Ground	1250
17-06-20	SBC 00017	Baker	Dan	Medium	Ground	1000
17-06-20	SBC 00017	Baker	Dan	light	Whole	2000
17-06-20	SBC 00017	Baker	Dan	Medium	Whole	1250
17-06-20	SBC 00017	Baker	Dan	Medium	Whole	Should stop here
17-06-20	SBC 00017	Baker	Dan	Medium	Whole
17-06-20	SBC 00017	Baker	Dan	Medium	Whole
17-06-20	SBC 00017	Baker	Dan	Medium	Whole
17-06-20	SBC 00017	Baker	Dan	Medium	Whole
17-06-20	SBC 00017	Baker	Dan	Medium	Whole

 

[Joe4]

OK, assuming that quantity is in column G, we only need to make a few tweaks:

Sub MyFillMacro()

    Dim lr as Long
    Dim rng as Range
   
'   Find last row with data in column G
    lr = Cells(Rows.Count, "G").End(xlUp).Row

'   Set range
    Set rng = Range("A1:G" & lr)

'   Fill in blanks with formulas
    rng.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = "=R[-1]C"
   
'   Turn formulas into values
    rng.Value = rng.Value

End Sub

 

[wolthers]

Adjusted as per your last code, but it continues filling all the way down.

The button is pressed on another sheet, could that be it? I tried activating the worksheet with Worksheets(6).Activate but it didn't help