Fetching data from a CSV file

Question

One of my professional software I use everyday provides analysis results in *.csv format from which I need to extract data. I have written a script that first converts from text to columns, and then takes out the data I need rearranging it the way I want. My problem is that it is not very fast while I will need to use it a lot. I am pretty sure it can be made more efficient with proper iterators but everything else I have tried I hit the wall somewhere along the way.

Now to the specifics. Here is how the Excel data looks like after I transform from text to column and delete some columns I know do not contain any interesting data.

Two columns are remaining:

xxx 
xxx 
xxx 
. 
. 
KnownText1 KnownText2 
Data1.1 Data1.2 
Data1.3 Data1.4 
. 
. 
Data1.m Data1.n 
xxx 
xxx 
xxx 
. 
Knowntext1 Knowntext2
Data2.1 Data2.2 
Data2.3 Data2.4 
. 
. 
Data2.k Data2.l
xxx
xxx

The xxx can be anything. Knowntext1 is always the same and shows the start of a new data block that needs to be captured. Number of blocks can vary as well as the number of rows within each block.

I want my data to become:

Knowntext1 Knowntext2 Knowntext1 Knowntext2 ... 
Data1.1 Data1.2 Data2.1 Data2.2 ... 
Data1.3 Data1.4 Data2.3 Data2.4 ... 
... 
Data1.m Data1.n Data2.k Data2.l ... 

Here is my VBA code. Any ideas on how to make an efficient iterator to do the same?

Sub CopyFromCSV()
Dim RngData As Range
Dim RngCopy As Range
Dim rCell As Range
Dim nTrims As Integer
Dim nDrafts As Integer
Dim maxDrafts As Integer
' Transform text to columns by "," seperator
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
 TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
 Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
 :=Array(1, 1), TrailingMinusNumbers:=True
' Removes the " " thousand seperator from the displacement column
Columns("A:A").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
 SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
 ReplaceFormat:=False
' Delete columns other than those containing information of Displacement and MaxVCG
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("C:Z").Select
Selection.Delete Shift:=xlToLeft
' Find the actual used range which we want to loop through
Set RngData = ActiveSheet.UsedRange
' Initialise variables for number of trim groups and the maximum number of drafts in all trim groups
nTrims = 0
maxDrafts = 0
With RngData
 'Loop through all cells in first column
 For Each rCell In .Columns(1).Cells
 ' If Value is "Intact Displ(MT)", a new trim group is detected
 If rCell.Cells(1, 1).Value = "Intact Displ(MT)" Then
 nTrims = nTrims + 1 'Number of trims groups incremented
 nDrafts = 1 'Number of drafts in this trim group initialised to 1
 Set RngCopy = rCell.Resize(1, 2) 'Initiate the range that will include data for this trim group
 ' If Value is numeric, it means the row contains data for the initiated trim group
 ElseIf IsNumeric(rCell.Cells(1, 1).Value) Then
 nDrafts = nDrafts + 1 'Number of drafts in the trim group incremented
 Set RngCopy = RngCopy.Resize(nDrafts, 2) 'Range to be copied is updated
 If nDrafts > maxDrafts Then
 'In case not all trim groups have the same amount of drafts, we need to set maxDrafts to know the size of the final selection
 maxDrafts = nDrafts
 End If
 ' If another type of data is detected, the range to be copied is frozen and copied at the top of the sheet, after the last column
 ' Test on nTrims > 0 necessary to avoid the action to occur before any valuable data is detected
 ElseIf Not (IsNumeric(rCell.Cells(1, 1).Value)) And nTrims > 0 Then
 RngCopy.Copy
 Cells(1, 2 * nTrims + 1).Select
 ActiveSheet.Paste
 End If
 Next rCell
End With
' Relevant data was copied after last column
' First two columns of original data can be deleted
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
' Numeric data of the transformed table is selected and sent to clipboard ready to paste in global spreadsheet
Range(Cells(2, 1), Cells(maxDrafts, 2 * nTrims)).Select
Selection.Copy
End Sub

Answer 1

Your main slow-down there is that you are copying and recopying the interesting data on every xxxx line. That's fairly easy to fix.

Your With RngCopy construct didn't appear to be doing anything, so I removed it. In any case it is not a great idea to have a 'With` block that reallocates the referenced object internally.

You would do well to use "Select" a lot less often, and there is no need to continuously redefine RngCopy. Here is an update that should run quicker and look calmer:

Sub CopyFromCSV()
Dim RngData As Range
Dim RngCopy As Range
Dim rCell As Range
Dim nTrims As Integer
Dim nDrafts As Integer
Dim maxDrafts As Integer
' Transform text to columns by "," seperator
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
 TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
 Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
 :=Array(1, 1), TrailingMinusNumbers:=True
' Removes the " " thousand seperator from the displacement column
Columns("A:A").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
 SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
 ReplaceFormat:=False
' Delete columns other than those containing information of Displacement and MaxVCG
Columns("B:B").Delete Shift:=xlToLeft
Columns("C:Z").Delete Shift:=xlToLeft
' Initialise variables for number of trim groups and the maximum number of drafts in all trim groups
nTrims = 0
nDrafts = 0 ' nDrafts > 0 will mean we are in a data group
maxDrafts = 0
'Loop through all cells in first column
For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
 ' First check for data group to copy
 ' If non-numeric data is detected, any range to be copied is copied to the top of the sheet, after the last column
 ' Test on nDrafts > 0 to only paste valuable data, and only once
 If Not (IsNumeric(rCell.Cells(1, 1).Value)) And nDrafts > 0 Then
 RngCopy.Resize(nDrafts, 2).Copy Destination:=Cells(1, 2 * nTrims + 1)
 If nDrafts > maxDrafts Then maxDrafts = nDrafts
 nDrafts = 0 ' we have copied this data, don't copy again
 End If
 ' If Value is "Intact Displ(MT)", a new trim group is detected
 If rCell.Cells(1, 1).Value = "Intact Displ(MT)" Then
 nTrims = nTrims + 1 'Number of trims groups incremented
 nDrafts = 1 'Number of drafts in this trim group initialised to 1
 Set RngCopy = rCell 'Initiate the range that will include data for this trim group
 ' If Value is numeric, it means the row contains data for the initiated trim group
 ElseIf IsNumeric(rCell.Cells(1, 1).Value) And nDrafts > 0 Then
 nDrafts = nDrafts + 1 'Number of drafts in the trim group incremented
 End If 
Next rCell
' Copy any remaining data group
If nDrafts > 0 Then
 RngCopy.Resize(nDrafts, 2).Copy Destination:=Cells(1, 2 * nTrims + 1)
 If nDrafts > maxDrafts Then maxDrafts = nDrafts
End If
' Relevant data was copied after last column
' First two columns of original data can be deleted
Columns("A:B").Delete Shift:=xlToLeft
' Numeric data of the transformed table is selected and sent to clipboard ready to paste in global spreadsheet
Range(Cells(2, 1), Cells(maxDrafts, 2 * nTrims)).Select
Selection.Copy
End Sub

• Joffan: One thing I can't quite work out is how you are replacing out the spaces in column A and then testing for a text phrase that has a space in it. Maybe this works for your data, but I had to work around it.