I need help in shortening the code as far as possible. Please help! Thanks

[pedie]

Hi
Below is my current code.
What it does is copy the selection offset, loop and paste in next empty row.....with selection it gives lines...etc...
I want the macro to give 1 gap (blank row) before pasting....
and i want the top row on the table to be in blue colour.

Please edit the code for me.
Thanks alot for helping!

Sub Macro1()
    Sheets("yahoo").Select
    'unprotect timer
    ActiveSheet.unprotect Password = "123"
          Range("B2").Select
          Selection.CurrentRegion.Select
          Selection.Copy
          Range("B11").Select
          Do Until ActiveCell.Value = ""
          ActiveCell.Offset(1, 0).Select
          Loop
          Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                                 xlNone, SkipBlanks:=False, Transpose:=False
                             'fomat here
 
               With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Macro10
 
 
    ' clear prev information
    Range("C3:C6").Select
    Selection.ClearContents
    Range("E3:E6").Select
    Selection.ClearContents
    Range("G3:H7").Select
    Columns("B:I").EntireColumn.AutoFit
    Application.CutCopyMode = False
    Cells(1).Select
End Sub
Sub Macro10()
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    Range("B11").Select
    ActiveSheet.unprotect Password = "123"
End Sub

 

[HalfAce]

my code in the top work fine but with no blank row in between!

Hi Pedie,
What you'll find is you can't use .end(xlDown).Offset(1) to leave a blank row between each paste. That bit will give you the first blank row after your data.
One would think simply changing the Offset(1) to Offset(2) would work, and it will the first time.... after that xlDown will find that blank row and stop, (Offset and paste) thereby over writing the first set of pasted data with the second, the second with the third and so on.

A better approach might be to start from the bottom and go up until it finds data, then offset 2 rows down. (ie)
Instead of :

Range("B11").End(xlDown).Offset(2)

you can try

Cells(Rows.Count, "B").End(xlUp).Offset(2)

Play with the two a bit and check out the differences. You'll see what I mean.

 

[pedie]

Dan..there u are...!!!
I thought you could be busy so did not want to bother you....
I'll for sure check the differences...and there is no doubt now that it'll work now....

Thanks!

Pedie

 

[meldoc]

Ok Pedie

Try this.

<font face=Courier New>  <SPAN style="color:#00007F">Set</SPAN> ws1 = Worksheets("yahoo")<br>  <SPAN style="color:#00007F">Set</SPAN> ws2 = Worksheets("Sheet2")<br>    ws1.Unprotect Password = "123"<br>      ws1.Range("C4:F11").Copy<br>        <SPAN style="color:#00007F">With</SPAN> ws2<br>          lr = .Cells(Rows.Count, "B").End(xlUp).Row<br>          .Cells(lr + 2, "B").PasteSpecial Paste:=xlPasteValuesAndNumberFormats<br>                      <SPAN style="color:#007F00">' format here</SPAN><br>             <SPAN style="color:#00007F">With</SPAN> .Range("B" & lr + 2 & ":E" & lr + 9)<br>              .Borders(xlEdgeLeft).Weight = xlMedium<br>              .Borders(xlEdgeTop).Weight = xlMedium<br>              .Borders(xlEdgeBottom).Weight = xlMedium<br>              .Borders(xlEdgeRight).Weight = xlMedium<br>              .Borders(xlInsideVertical).Weight = xlHairline<br>              .Borders(xlInsideHorizontal).Weight = xlHairline<br>                      <SPAN style="color:#007F00">' format here 2</SPAN><br>              .HorizontalAlignment = xlCenter<br>              .VerticalAlignment = xlCenter<br>              .WrapText = <SPAN style="color:#00007F">True</SPAN><br>              .Orientation = 0<br>              .AddIndent = <SPAN style="color:#00007F">False</SPAN><br>              .IndentLevel = 0<br>              .ShrinkToFit = <SPAN style="color:#00007F">False</SPAN><br>              .ReadingOrder = xlContext<br>              .MergeCells = <SPAN style="color:#00007F">False</SPAN><br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>          .Columns("B:E").EntireColumn.AutoFit<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>                      <SPAN style="color:#007F00">' clear prev information</SPAN><br>    <SPAN style="color:#00007F">With</SPAN> ws1<br>      .Range("D3:F11").ClearContents<br>      .Activate<br>      .Cells(1).Select<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>  Application.CutCopyMode = <SPAN style="color:#00007F">False</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[Norie]

You can sometimes combine some of the border formatting like this.

.Borders.Weight = xlMedium

 

[xld]

That is not short enough...someone please edit it....

Cheeky b*##!r