Making 4 columns from 2 columns

[rlnye]

In Excel 2000, a spreadsheet I use extracts data in two columns (column A1 is numeric and B1 in descriptive text) the number of rows in the two columns varies...sometimes just 6 rows in the two columns othertimes 32 rows. What I need to do is if the number of rows in A1:B? is over 15, divide the number of rows in half and copy the bottom half to D1. In other words if the number of rows is A1:B24...copy the bottom 12 rows A13:B24 to D1. If I need to use VB code can someone help with the code...I'm a new comer to Excel. Thanks

 

[Andrew Poulsom]

Try this:

Sub Test()
    Dim Source As Range
    Dim Target As Range
    Dim RowCount As Long
    Dim Half As Long
    Set Source = Range("A1:B" & Range("A1").End(xlDown).Row)
    If Source.Rows.Count <= 15 Then Exit Sub
    Set Target = Range("D1")
    RowCount = Source.Rows.Count
    Half = Int(Source.Rows.Count / 2 + 0.5)
    Set Source = Source.Offset(Half, 0).Resize(RowCount - Half)
    Source.Cut Target
End Sub

 

[rlnye]

Andrew, thanks for the VB code, it works great! I have a little problem that I created by inserting a few simple macro codes in with what you gave me. The problem is, if the number of rows is less than 15 the macro ends. What I need to do is have it make two rows if the number of rows are more than 15...which it does. Or, continue to run the other macro code if the number of rows is less than 15. Can you use some form of "loop?"

Thanks again for the help

 

[Andrew Poulsom]

Like this?

Sub Test()
    Dim Source As Range
    Dim Target As Range
    Dim RowCount As Long
    Dim Half As Long
    Set Source = Range("A1:B" & Range("A1").End(xlDown).Row)
    If Source.Rows.Count <= 15 Then
       Set Target = Range("D1")
       RowCount = Source.Rows.Count
       Half = Int(Source.Rows.Count / 2 + 0.5)
       Set Source = Source.Offset(Half, 0).Resize(RowCount - Half)
       Source.Cut Target
    End If
End Sub

 

[rlnye]

Andrew, thank you very much...you have saved me many, many brain cells that I cannot afford to lose. It works great!

Thanks again.

 

[rlnye]

Andrew, thank you very much...you have saved me many, many brain cells that I cannot afford to lose. It works great!

Thanks again.

 

[rlnye]

Andrew, thank you very much...you have saved me many, many brain cells that I cannot afford to lose. It works great!

Thanks again.

 

[rlnye]

Andrew, I guess I spoke to soon. I copied the complete macro below...what I really am trying to do is, if the number of rows is >=15 then make two rows, if it is <=15 run the macro code below the code you gave me. I hope this makes sense...thanks again.

Sub MakeFinalBidSheet()
'
' MakeFinalBidSheet Macro
' Macro recorded 9/11/2002 by Ronnie
'

Sheets("Sign WorkSheet & Bid Sheet").Range("B8:D141").AdvancedFilter Action:= _
xlFilterCopy, CriteriaRange:=Sheets("Sign WorkSheet & Bid Sheet").Range( _
"C4:C5"), CopyToRange:=Range("A1"), Unique:=False
Range("A1:D55").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft

Dim Source As Range
Dim Target As Range
Dim RowCount As Long
Dim Half As Long
Set Source = Range("A1:B40" & Range("A1").End(xlDown).Row)
If Source.Rows.Count <= 15 Then
Set Target = Range("E1")
RowCount = Source.Rows.Count
Half = Int(Source.Rows.Count / 2 + 0.5)
Set Source = Source.Offset(Half, 0).Resize(RowCount - Half)
Source.Cut Target
End If

Sheets("Legal Description").Select
ActiveWindow.ScrollRow = 1
Range("A22:A34").Select
Selection.Copy
Sheets("Bid Sheet WorkSheet").Select

Dim LastRow As Long
Dim NextRow As Long

' determine where the data ends on Column A Legal Description
Worksheets("Legal Description").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Select
LastRow = ActiveCell.Row

' copy the data from Column A in Legal Description Worksheet
Range("A22:A34").Copy

' Determine where to add the new data in Column A of Bid WorkSheet
Worksheets("Bid Sheet WorkSheet").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Offset(3, 0).Select
NextRow = ActiveCell.Row
ActiveSheet.Paste
Application.CutCopyMode = False

' paste the data to Column A Sign WorkSheet & Bid Sheet
' Worksheets("Bid Sheet WorkSheet").Range("A" & NextRow).Select
' ActiveSheet.Paste
' Application.CutCopyMode = False
' ActiveSheet.Paste

End Sub

 

[Andrew Poulsom]

Set Source = Range("A1:B40" & Range("A1").End(xlDown).Row)

should be

Set Source = Range("A1:B" & Range("A1").End(xlDown).Row)

Other than that, what isn't working?

 

[rlnye]

Andrew, it makes two rows if the number of rows is 15 or less. What I need to do is make two rows only if there is 15 or more rows...and if less than or more than 15 rows, to continue to run the VB code under your code.

Thanks for taking the time to help.