how to copy a single cell to another sheet and pasting to 18 cells and loop until blanks on source sheet

Question

hiya all thanks in advance for any help

my goal is to transfer all the data from a discount grid and converting it to a list format

i have the grid as the source sheet and i am creating a new sheet ready for import to a new system which needs it laying out in a list format name(A)-type(B)-(C)-discount(D) (column c must be blank)

1 i need to take the company name and copy it 17 more times (for each product type)

2 i then take the product types from the top and transpose into next column

3 i then miss out 1 column then copy and transpose in the discount values in the next column

this then needs to be repeated until it finds a blank on the source page

i have constructed a basic macro but it means ill have to redo for each customer which currently stands at 939 customers (nightmare) is there a set of commands i can put into my macro to achive this ?

here is a copy of my current code

    Workbooks.Add
    ChDir "F:\darren t"
    ActiveWorkbook.SaveAs Filename:="F:\darren t\Ready Discount Grid.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Windows("Tools for ball.xlsm").Activate
    Workbooks.Open Filename:="F:\darren t\DISCOUNTS GRID M2M.xlsx"
    Cells.Select
    Selection.ClearFormats
    Cells.EntireColumn.AutoFit
    Range("B2:S936").Select
    Range("S936").Activate
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = "0"
    Range("A2").Select

'Create grid names

    Windows("Ready Discount Grid.xlsx").Activate
    Application.CutCopyMode = False
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Customer Account Code"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Blind Type Code"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Option Stock Code"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Discount %"
    Cells.Select
    Cells.EntireColumn.AutoFit

' paste names (repeat 938 times)

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("A2").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("A2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A2:A19"), Type:=xlFillDefault
    Range("A2:A19").Select

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("A3").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("A20").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A20:A37"), Type:=xlFillDefault
    Range("A20:A37").Select

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("A4").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("A38").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A38:A57"), Type:=xlFillDefault
    Range("A38:A57").Select

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("A5").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("A58").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A58:A73"), Type:=xlFillDefault
    Range("A58:A73").Select

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("A6").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("A74").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A74:A91"), Type:=xlFillDefault
    Range("A74:A91").Select

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("A7").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("A92").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A92:A109"), Type:=xlFillDefault
    Range("A92:A109").Select

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("A8").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("A110").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A110:A127"), Type:=xlFillDefault
    Range("A110:A127").Select

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("A9").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("A128").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A128:a145"), Type:=xlFillDefault
    Range("A128:A145").Select

' paste types (repeat 938 times)

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("B1:W1").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("B1:W1").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("B20").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("B1:W1").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("B38").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False

'paste discount values (repeat 938 times)

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("B2:S2").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

        Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("B3:S3").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("D20").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

    Windows("DISCOUNTS GRID M2M.xlsx").Activate
    Range("B4:S4").Select
    Selection.Copy
    Windows("Ready Discount Grid.xlsx").Activate
    Range("D38").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

'Put rest of the data below here


End Sub

there must be a much more efficent way to do this

any help would be amazing

too long didnt even read... please post a **small** snippet of your code that doesnt work with a description. — , Jul 07 '14 at 15:08
Use a loop structure. See [here](http://msdn.microsoft.com/en-us/library/office/jj692812(v=office.15).aspx) for a list of VBA statements which include `For Each ... Next` and `For ... Next` statements. Also see [here](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros) to avoid using "Activate" and "Select" methods in VBA programming. — David Zemens, Jul 07 '14 at 15:12
not really fair to minus 1 me based on trying to be informative rather than vague but i appreciate the honesty — Scromby, Jul 07 '14 at 15:19
thank you for both answers im now well on my way to being more efficient :) — Scromby, Jul 08 '14 at 08:41

score 0 · Accepted Answer · answered Jul 07 '14 at 19:09

0

This could help

Do while activecell.value <> ""
   'Code that must repeat

   Activecell.Offset(1,0).Active 'Moves the active cell
Loop

activecell.value

Evaluates the activecell value, which one in the case that it's empty will stop

answered Jul 07 '14 at 19:09

WltrRpo

263
2
13

how to copy a single cell to another sheet and pasting to 18 cells and loop until blanks on source sheet

1 Answers1