Copying then deleting every second row

[Joseph]

I have a report that comes from our mainframe. Each record is on two
rows. I need to copy every second row (i.e. A2:B2) to the right of the
data on the first row (i.e. H1) and then delete the second row.

Here's what I tried:
1) Filter for something unique in the first row of each record
2) Select visible cells in column H
3) Add a formula to column H to pick up the values from the second row
4) Convert formulas to values in column H
5) Filter for something unique in the second row of each record
6) Select visible cells
7) Delete (visible) rows (i.e. every seond row)

This worked fine when I was working with 10,000 records. But when my
report contains more than 20,000 records, Excel cannot select visible
cells. I get a message saying it's too complex.

I tried looping through the cells and it gets the job done but with
40,000 records, it's s-l-o-o-o-o-w.

Any suggestions for another workaround. Assume that the first row in
each record has data in columns A:G and the second row has data in
columns A:B.

I appreciate your help.
Joe

 

[Chris Marlow]

Joe,

I'd use VBA. Presuming your file is 'plain text' and comma delimited the
code below would work. It gets more complicated if you have a more structured
document (comma delimited with quotes marking text etc). You need to set a
reference to 'Microsoft Scripting Runtime' to use FileSystemObject/TextStream.

Public Sub LoadFile()

Dim sFileName As String
Dim fso As New FileSystemObject
Dim fsoTextStream As TextStream
Dim sOddLine As String
Dim sEvenLine As String
Dim arrOddLine() As String
Dim arrEvenLine() As String
Dim lRowPointer As Long
Dim iColPointer As Integer

sFileName = "C:\myfile.txt" 'put you file name here

Set fsoTextStream = fspenTextFile(sFileName, ForReading)

lRowPointer = 1

ThisWorkbook.Sheets(1).Cells.ClearContents

Do Until fsoTextStream.AtEndOfStream

sOddLine = fsoTextStream.ReadLine
sEvenLine = fsoTextStream.ReadLine

arrOddLine() = Split(sOddLine, ",")
arrEvenLine() = Split(sEvenLine, ",")

For iColPointer = 1 To 7

ThisWorkbook.Sheets(1).Cells(lRowPointer, iColPointer) =
arrOddLine(iColPointer - 1)

Next iColPointer

For iColPointer = 8 To 9

ThisWorkbook.Sheets(1).Cells(lRowPointer, iColPointer) =
arrEvenLine(iColPointer - 8)

Next iColPointer

lRowPointer = lRowPointer + 1

Loop

fsoTextStream.Close

End Sub

Regards,

Chris.

 

[Yngve]

Hi Joseph

You can try this, but this is I assumed that the first row in
each record has data in columns A:G and the second row has data in
columns A:B.

And thangs to Toppers.

I adapted it from Toppers DeleteX() and rearangerte that.



Sub MoveDelete()
Dim st As Variant
Dim n As Variant
Dim x As Variant
Dim i As Double


Application.ScreenUpdating = False
st = Timer
n = Cells(Rows.Count, "A").End(xlUp).Row
'transfer to vba array
x = Range("a1:i" & n)



For i = 1 To UBound(x, 1) Step 2


On Error Resume Next
' check if (cells i,g) <> "" and (cells i + 1,C) = ""
If x(i, 7) <> "" And x(i + 1, 3) = "" Then
x(i, 8) = x(i + 1, 1)
x(i, 9) = x(i + 1, 2)
x(i + 1, 1) = ""
x(i + 1, 2) = ""
Else
' Do nothing
End If
On Error GoTo 0

Next i


Range("a1:I" & n) = x

Range("a1:I" & n).Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.ScreenUpdating = True
Dim ft As Variant
ft = Timer
MsgBox ft - st

End Sub

Regards Yngve