copy rows with individual numbers

Microsoft Windows xp inside out, second...
April 11, 2010 at 00:17:23
Specs: Windows XP, pentium 4 3.00Ghz. 1gb ram
How to copy the entire rows containing following individual numbers to sheet2? For example, sheet1 have following data where numbers are in col.L:

W/S at Tsangpo village             12
S/O No. PHE/33
W/S at  Tacha village              123
S/O No. PHE/33
---------------------------------- Blank row
W/S at  maro village               13
S/O No. PHE/33

Copy entire row to sheet2 like this:

W/S at Tsangpo village             1
S/O No. PHE/33
W/S at  Tacha village              1
S/O No. PHE/33
W/S at  maro village               1
S/O No. PHE/33
...........Seperated by blank row......
W/S at Tsangpo village             2
S/O No. PHE/33
W/S at  Tacha village              2
S/O No. PHE/33
...........Seperated by blank row......
W/S at  Tacha village              3
S/O No. PHE/33
W/S at  maro village               3
S/O No. PHE/33

Sheet1 data have a blank rows after every two rows of data.


See More: copy rows with individual numbers

Report •


#1
April 11, 2010 at 05:19:42
Hi,

When I look at your sample data, the only difference between what you have on Sheet1 and what you want on Sheet2 is that the numbers in column L have changed, and on sheet 2 they are sequential - changing at every blank row.
Am I right - or have I missed something.

If I am right, then run this macro which copies "Sheet1" to "Sheet2" (an empty worksheet named "Sheet2" must be present in the same workbook), it then numbers data in groups, incrementing the number at each blank row:

Sub LineNum()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim intCount As Integer

'copy Sheet1 to Sheet2 - assumes Sheet2 exists
Worksheets("Sheet1").Rows.Copy
Worksheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteAll

'set start of data
Set rngStart = Worksheets("Sheet2").Range("L2")
'find end of data
Set rngEnd = Worksheets("Sheet2") _
            .Range("L" & CStr(Application.Rows.Count)).End(xlUp)

'set counter
intCount = 1

'loop through the data in column L
For Each rngCell In Worksheets("Sheet2").Range(rngStart, rngEnd)
    'test for blank row (no data in column A or column L
    If rngCell.Offset(0, -11).Value = "" And rngCell.Value = "" Then
        'blank - so increment counter
        intCount = intCount + 1
        Else
        'not blank
        'test if number in column L
        If IsNumeric(rngCell.Text) Then
            'is a number - so replace it with counter value
            rngCell.Value = intCount
        End If
    End If
Next rngCell
End Sub
As Macros cannot be undone with the Undo button, test this macro on a copy of your data. Always make a backup of your Workbook before running this macro. This code has only been tested on sample data, and it has not been tested in your environment, so test it on copies of your data to ensure that it works 'as expected'.
Note that any data on "Sheet2" will be overwritten without warning.

*************************
If the above is not right, then I have a number of questions:

1. In your post you say Sheet1 data have a blank rows after every two rows of data.
but the data you posted shows a blank row after four rows of data - please clarify.

2. On Sheet2, the first group is shown as 6 rows of data before the first blank row, then the next two groups are 4 rows each. If this is correct how do you determine whether data from Sheet1 is copied in groups of four rows or groups of six rows.

3. Which columns is the data in.

4. Do you want all columns up to column L copied, (A to K), or only certain columns.


Regards


Report •

#2
April 11, 2010 at 23:10:36
1. My mistake in the OP. Yes sheet1 data have a blank rows after every two rows of data beginning at row No.16.

2. Actually it depends on number of a particular digit contains in col.L. Say, if there are 12 ones in Col.L then rows of data containing ones(+1 row below it) in Col.L should be copied in one group. So for 2's, 3's, 4's, etc. upto 9 while group of these 1's, 2's, 3's etc. are seperated by a blank rows.

3. Data are in Col. A to K while digits are in Col.L

4. Yes all columns upto column L copied.

Further I want to say that the increment of number is not so important rather grouping of rows of data containing particular digit in col.L is important and thats what i want to achieve.

Following code does what i need except that it does not copying row that contain S/O No. PHE/33

Sub Expand()
  Dim oCell As Range
  Dim lCt As Long
  Dim lCurRow As Long
  For lCt = 1 To 9
      For Each oCell In Intersect(ActiveSheet.UsedRange, Range("B:B")).Cells
          If InStr(oCell.Offset(, 10).Value, lCt) > 0 Then
              lCurRow = lCurRow + 1
              Worksheets("Sheet2").Range("B1").Offset(lCurRow + 1).EntireRow.Value = oCell.EntireRow.Value
              Worksheets("Sheet2").Range("B1").Offset(lCurRow + 1, 10).Value = lCt
          End If
      Next
      lCurRow = lCurRow + 1
  Next
End Sub


Report •

#3
April 12, 2010 at 05:45:35
Hi,

Try this:

Sub LineNum()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim intMax As Integer
Dim intDestOffst As Integer
Dim blnfound As Boolean
Dim n As Integer

On Error GoTo ErrHnd

'turn off screen updating
Application.ScreenUpdating = False

'set start of data
Set rngStart = Worksheets("Sheet1").Range("L16")
'find end of data
Set rngEnd = Worksheets("Sheet1") _
            .Range("L" & CStr(Application.Rows.Count)).End(xlUp)
'set destination data row offset counter
intDestOffst = 0

'find maximum value in column L
intMax = Application.WorksheetFunction. _
        Max(Worksheets("Sheet1"). _
        Range(rngStart.Address & ":" & rngEnd.Address))

'look for each number from 1 to intMax
For n = 1 To intMax
    'set flag to 'not found' for 'this' number
    blnfound = False
    'loop through the data in column L
    For Each rngCell In Worksheets("Sheet1").Range(rngStart, rngEnd)
        'test for 'this' number in column L
        If rngCell.Value = n Then
            'move two rows of data (cols. A to L) to Sheet2
            rngCell.Offset(0, -11).Resize(2, 12).Copy _
                    Destination:=Worksheets("Sheet2").Range("A2"). _
                    Offset(intDestOffst, 0)
            'increment destination offset by 2
            intDestOffst = intDestOffst + 2
            'flag that we found 'this' number
            blnfound = True
        End If
    Next rngCell
    'test if 'this' number was found
    If blnfound = True Then
        'at least one found, so leave a blank line
        intDestOffst = intDestOffst + 1
    End If
Next n
'turn screen updating on again
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'turn screen updating on again
Application.ScreenUpdating = True
End Sub

The data is moved to Sheet2 in groups according to the number in column L (all 1's go together, then all 2's and so on).
The data starts at row 2 on the destination Sheet2.
You can change this by changing A2 to another row (but don't change the column) in this piece of code:
Destination:=Worksheets("Sheet2").Range("A2").

Regards


Report •

Related Solutions

#4
April 12, 2010 at 22:36:14
Humar, Please see my Original Post example once again. I think it tells everything. Here was the example:

Before running Macro(in sheet1)

W/S at Tsangpo village             12
S/O No. PHE/33
---------------------------------- Blank row
W/S at  Tacha village              123
S/O No. PHE/33
---------------------------------- Blank row
W/S at  maro village               13
S/O No. PHE/33

After running macro (in sheet2)

W/S at Tsangpo village             1
S/O No. PHE/33
W/S at  Tacha village              1
S/O No. PHE/33
W/S at  maro village               1
S/O No. PHE/33
...........Seperated by blank row......
W/S at Tsangpo village             2
S/O No. PHE/33
W/S at  Tacha village              2
S/O No. PHE/33
...........Seperated by blank row......
W/S at  Tacha village              3
S/O No. PHE/33
W/S at  maro village               3
S/O No. PHE/33

Here you can see that "W/S at Tacha village" contains three digits in Col.L namely, 123. Therefore the "W/S at Tacha village" should be copied trice;
i) to digit1 group
ii) to digit 2 group and
iii) to digit 3 group.

After running macro Single digit should appear in sheet2 Col.L as opposed to multiple digits in sheet1 Col.L


Report •

#5
April 13, 2010 at 05:17:32
Hi,

OK, so the numbers in column L are not really numbers, they are a string of individual characters.
123 is treated as three characters or digits "1", "2" and "3"
As a result, the two rows of data get copied into three groups: group 1, group 2 and group 3.
If column L contained 9876, the two rows would get copied to four groups: group 6, group 7, group 8 and group 9.

There are only nine groups, so each character in the cells in column L is a digit.

The following macro copies the pairs of rows to the group or groups represented by the string of characters in column L.
There is a blank line after each group on Sheet2.

Sub LineNum()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim intDestOffst As Integer
Dim strDig As String
Dim blnfound As Boolean
Dim m As Integer
Dim n As Integer

On Error GoTo ErrHnd

'turn off screen updating
Application.ScreenUpdating = False

'set start of data
Set rngStart = Worksheets("Sheet1").Range("L16")
'find end of data
Set rngEnd = Worksheets("Sheet1") _
            .Range("L" & CStr(Application.Rows.Count)).End(xlUp)
'set destination data row offset counter
intDestOffst = 0

'look for each group from 1 to 9
For n = 1 To 9
    'set flag to 'not found' for 'this' number
    blnfound = False
    'loop through the data in column L
    For Each rngCell In Worksheets("Sheet1").Range(rngStart, rngEnd)
        'test for group number in column L
        'get each digit in the text
        For m = 1 To Len(rngCell.Text)
            strDig = Mid(rngCell.Text, m, 1)
            'test if the digit equals this group number
            If strDig = CStr(n) Then
                'put the group number in column L
                Worksheets("Sheet2").Range("A2").Offset(intDestOffst, 11).Value = n
                'move two rows of data (cols. A to K)to worksheet 2
                rngCell.Offset(0, -11).Resize(2, 11).Copy _
                        Destination:=Worksheets("Sheet2").Range("A2"). _
                        Offset(intDestOffst, 0)
                'increment destination offset by 2
                intDestOffst = intDestOffst + 2
                'flag that we found 'this' number
                blnfound = True
            End If
        Next m
    Next rngCell
    'test if 'this' number was found
    If blnfound = True Then
        'at least one found, so leave a blank line
        intDestOffst = intDestOffst + 1
    End If
Next n
'turn screen updating on again
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'turn screen updating on again
Application.ScreenUpdating = True
End Sub

Regards


Report •

#6
April 13, 2010 at 23:15:50
Thanks Humar, the code you provided works exactly as i need it
to be. Have a nice day.

Report •


Ask Question