Excel VBA Copy Rows To Column plus match Field Headers

[Biz]

Dear All

I have created vba to copy rows to Columns. It works but it’s very slow.

As more entries are it would become slower.
Is it possible to make it faster?

Please not in my main macro I use SpeedOn and SpeedOff

Sub DataTranfer()
    Dim rngCopy As Range
    Dim rngPaste As Range
    Dim rngStart As Range
    Dim rngEnd As Range
    Dim lr As Long
    Dim r, c As Single
    Dim rCells As Range
    Dim lCol As Long
    Dim sCol As String
    
    'Find Last Column on Data Worksheet tab
    With wsDestination
        lCol = .Cells.Find(What:="*", _
            After:=.Range("A1"), _
            LookAt:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Column
    End With
    sCol = ColNumToLetter(lCol)
    
    Set rngStart = searchRng
    Set rngEnd = ws.Range("A" & ws.Range("A" & Rows.Count).End(xlUp).Row)
    
    For Each rngCopy In ws.Range(Range(searchRng, rngEnd).Address).SpecialCells(xlCellTypeConstants).Areas
        Set rngPaste = wsDestination.Range("A" & Application.Max(2, wsDestination.Range("A" & Rows.Count).End(xlUp).Row + 1))
        
        'Loop thru rngCopy Cells
        For Each rCells In rngCopy
            
            'Match Column Header to make sure correct information is pasted
            c = Application.Match(rCells, wsDestination.Range("A1:" & sCol & 1), 0)
            r = 0
            
            'Copy items from Col B
            rngPaste.Offset(r, c - 1) = rCells.Offset(0, 1).Value
        Next rCells
    Next rngCopy
    
    'Formating
    lr = wsDestination.Range("A" & Rows.Count).End(xlUp).Row
    With wsDestination
        .Range("C2:C" & lr).NumberFormat = "dd/mm/yyyy"
        .Range("F2:G" & lr).NumberFormat = "dd/mm/yyyy"
        .Range("M2:O" & lr).NumberFormat = "dd/mm/yyyy"
    End With
    
    wsDestination.Cells.EntireColumn.AutoFit
    
    'Release memory
    Set rngStart = Nothing
    Set rngEnd = Nothing
    Set rngPaste = Nothing
    
    
End Sub

Private Sub SpeedOn()
    'Speeding Up VBA Code
    With Application
        .ScreenUpdating = False 'Prevent screen flickering
        '.Calculation = xlCalculationManual 'Preventing calculation
        .DisplayAlerts = False 'Turn OFF alerts
        .EnableEvents = False 'Prevent All Events
    End With
End Sub
Private Sub SpeedOff()
    'Speeding Up VBA Code
    With Application
        .ScreenUpdating = True 'Prevent screen flickering
        '.Calculation = xlAutomatic 'Preventing calculation
        .DisplayAlerts = True 'Turn OFF alerts
        .EnableEvents = True 'Prevent All Events
    End With
End Sub

Your help would be greatly appreciated.

Kind Regards

Biz

 

[Jerry Sullivan]

Hi Mate,

I looked at the file you sent me which showed the Main calling procedure and other called subs.

The process can be done much faster through the use of arrays. It's faster to process data in arrays than to do read/write and worksheet formula functions on range objects. That also eliminates the need for a temporary copy of the source data worksheet.

Here's some code you can try. In my testing on your dataset there was about a 100x reduction in processing time (5 seconds --> 0.04 seconds).

Sub aMain()
 Dim lLastColParams As Long, lLastRow As Long
 Dim lSourceRow As Long, lFirstPosition As Long, lRecord As Long
 Dim sField As String
 Dim vFieldNdx As Variant, vHeaders As Variant
 Dim vSource As Variant, vResults As Variant
 Dim wsSource As Worksheet, wsDestination As Worksheet, wsParams As Worksheet
     
 ' declare sheet variables
 Set wsSource = Sheets("Active")
 Set wsDestination = Sheets("Data")
 Set wsParams = Sheets("Parameters")
   
 wsDestination.UsedRange.ClearContents
   
 ' update headers named range and read params into array
 With wsParams
   lLastColParams = .Cells(.Range("Headers").Row, .Columns.Count).End(xlToLeft).Column
   
   ActiveWorkbook.Names.Add Name:="Headers", _
      RefersTo:=.Cells(.Range("Headers").Row, "A").Resize(1, lLastColParams)
   vHeaders = Range("Headers").Value
 End With

 With wsSource
   lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   vSource = .Range("A1:B" & lLastRow).Value
   ' size array for max scenario
   ReDim vResults(1 To lLastRow, 1 To lLastColParams)
 End With
 
 ' find first position
 For lSourceRow = 1 To UBound(vSource, 1)
   If vSource(lSourceRow, 1) = "POSITION" Then
      lFirstPosition = lSourceRow
      Exit For
   End If
 Next lSourceRow

 If lFirstPosition = 0 Then
   MsgBox "No Positions found"
   Exit Sub
 End If

 ' transpose records into matching fields
 For lSourceRow = lFirstPosition To UBound(vSource, 1)
   sField = vSource(lSourceRow, 1)
   vFieldNdx = Application.Match(sField, vHeaders, 0)
   If IsNumeric(vFieldNdx) Then
      If sField = "POSITION" Then
         ' start next record
         lRecord = lRecord + 1
      End If
      ' write value to matching field in results array
      vResults(lRecord, CLng(vFieldNdx)) = vSource(lSourceRow, 2)
   End If
 Next lSourceRow

 With wsDestination
   With .Range("A2").Resize(lRecord, UBound(vHeaders, 2))
      .Value = vResults
      ' format dates
   End With
   
   ' write headers based on parameters then format
   With .Range("A1").Resize(1, UBound(vHeaders, 2))
      .Value = vHeaders
      .Font.Bold = True
      .EntireColumn.AutoFit
   End With
   
   Call FindAllDatesFormat(rData:=.Range("A1").Resize(lRecord + 1, _
      UBound(vHeaders, 2)), sFormat:="dd/mm/yyyy")
   
   .Cells.EntireColumn.AutoFit
 End With
 
 ' teleport back
 Application.Goto wsParams.Range("A1")
    
End Sub

Sub FindAllDatesFormat(rData As Range, sFormat As String)
'--finds partial matches for "Date" in first row of dataset
'  then applies specified format to each matching data field
    
 Dim rHeader As Range
 
 For Each rHeader In rData.Resize(1)
   If LCase$(rHeader.Value) Like "*date*" Then
      With rHeader.Offset(1).Resize(rData.Rows.Count - 1)
         .NumberFormat = "dd/mm/yyyy"
         .Value = .Value
      End With
   End If
 Next rHeader
 
End Sub

 

[Biz]

Hi Jerry,

Your code looks better and performs very fast.
I will look at your code and try to understand and improve my coding technique.


Kind Regards

Biz

 

[Biz]

Hi Jerry,
Could you post your code for VBA run time as it seems more accurate 0.04 secs where as mine registers 0.

Kind Regards

Biz

 

[Jerry Sullivan]

Biz, I use the MicroTimer code provided in this article....

Excel 2010 Performance: Improving Calculation Performance

Modify the code slightly to call your macro instead of doing one of the recalculation types.

 

[Biz]

Hi Jerry,

Thank you for your help and weblink.

Biz