2
\$\begingroup\$

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
\$\endgroup\$
1
\$\begingroup\$

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
\$\endgroup\$
  • \$\begingroup\$ 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. \$\endgroup\$ – Joffan Sep 16 '17 at 16:16

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.