acceleration of a macros formation of data on new sheet

[Lichress]

Hi, please, look whether it is possible to accelerate action of a macros?

[SamT]

Let me tell you. You used rng1.Column all over the place, first to set the value of "clnUslug." (I chnged"clnUslug" to "ServiceCol".) So I figured that in the interset of speed I would replace all rng1.Column with "ServiceCol." Lucky for you I caught it at the last minute and added ClientCol.

Try This

Option Explicit

Sub macros()

    Dim wsh1 As Worksheet, wsh2 As Worksheet
    Dim i As Long, rowLast&, rowCurr&, ServiceCol&
    Dim ClientCol As Long
    Dim rng1 As Range
    Dim oDict As Object
    Dim SrcRow As Range, DestRow As Range

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
     
    Set wsh1 = Worksheets("Sheet1")
    
    Set rng1 = wsh1.Cells.Find(What:="service")
    If rng1 Is Nothing Then Exit Sub
    ServiceCol = rng1.Column
     
    Set rng1 = wsh1.Cells.Find(What:="client")
    If rng1 Is Nothing Then Exit Sub
    ClientCol = rng1.Column
    rowLast = wsh1.Cells(Rows.Count, ClientCol).End(xlUp).Row
     
    Set oDict = CreateObject("Scripting.Dictionary")
    Set wsh2 = Worksheets.Add(After:=wsh1)
    
    Set SrcRow = wsh1.Rows(1)
    Set DestRow = wsh2.Rows(1)         
      With SrcRow
        .Cells(ClientCol).Copy DestRow.Cells(1)
        .Cells(7).Copy DestRow.Cells(2)
        .Cells(12).Copy DestRow.Cells(3)
        .Cells(10).Copy DestRow.Cells(4)
        .Cells(2).Copy DestRow.Cells(5)
      End With
      
        rowCurr = 2
        
       With wsh1
        For i = rowLast To 2 Step -1
            If .Cells(i, ServiceCol).Value = "patronage" Then
                If Not oDict.exists(.Cells(i, rng1.Column).Value) Then
                    oDict(.Cells(i, ClientCol).Value) = rowCurr
                    .Cells(i, ClientCol).Copy wsh2.Cells(rowCurr, 1)
                    .Cells(i, 7).Copy wsh2.Cells(rowCurr, 2)
                    wsh2.Cells(rowCurr, 3) = wsh1.Cells(i, 11).Text + ", " + wsh1.Cells(i, 12).Text
                    .Cells(i, 10).Copy wsh2.Cells(rowCurr, 4)
                    .Cells(i, 2).Copy wsh2.Cells(rowCurr, 5)
                    rowCurr = rowCurr + 1
                Else
                    wsh2.Cells(oDict.Item(.Cells(i, ClientCol).Value), 5).Value _
                    = wsh2.Cells(oDict.Item(.Cells(i, ClientCol).Value), 5).Value & Chr(10) & .Cells(i, 2).Valu
                End If
            End If
        Next i
       End With
    
    wsh2.Range("A:E").EntireColumn.AutoFit
    
    With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

I ran the Macros button and got this result:

client	date of birth	street	category	date
John Smith	09.01.1580	London , Baker Street	writer	1/21/2017 1/14/2017
Bear Grylls	6/7/1974	London , Abbey Road	Survivalists	1/18/2017
Suelo	1/1/1961	Arvada, Ralston Road	Survivalists	1/13/2017

[p45cal]

Sub blah()
Set SceSht = Sheets("Sheet1")
Set oDict = CreateObject("Scripting.Dictionary")
oDict.comparemode = vbTextCompare  'case insensitive
Hdrs = Application.Transpose(Application.Transpose(SceSht.Cells(1).CurrentRegion.Rows(1)))
ServiceColm = Application.Match("service", Hdrs, 0)
ClientColm = Application.Match("client", Hdrs, 0)
myData = SceSht.Cells(1).CurrentRegion.Value
myresult = myData  'overkill, I know.
myResultRow = 1
myresult(1, 1) = "Client"
myresult(1, 2) = myData(1, 7)
myresult(1, 3) = Join(Array(myData(1, 11), myData(1, 12)), ", ")
myresult(1, 4) = myData(1, 10)
myresult(1, 5) = myData(1, 2)

For rw = UBound(myData) To 2 Step -1
  If Application.Trim(LCase(myData(rw, ServiceColm))) = "patronage" Then
    If Not oDict.exists(Application.Trim(myData(rw, ClientColm))) Then
      myResultRow = myResultRow + 1
      oDict(Application.Trim(myData(rw, ClientColm))) = myResultRow
      myresult(myResultRow, 1) = myData(rw, ClientColm)
      myresult(myResultRow, 2) = myData(rw, 7)
      myresult(myResultRow, 3) = Join(Array(Application.Trim(myData(rw, 11)), Application.Trim(myData(rw, 12))), ", ")
      myresult(myResultRow, 4) = myData(rw, 10)
      myresult(myResultRow, 5) = myData(rw, 2)
    Else
      myresult(oDict.Item(Application.Trim(myData(rw, ClientColm))), 5) = myresult(oDict.Item(Application.Trim(myData(rw, ClientColm))), 5) & Chr(10) & myData(rw, 2)
    End If
  End If
Next rw
With Sheets.Add(Sheets(Sheets.Count))
  .Range("A1").Resize(myResultRow, 5).Value = myresult
  .Range("A:E").EntireColumn.AutoFit
  .UsedRange.EntireRow.AutoFit
End With
End Sub

[p45cal]

Sod it. This version a bit more robust (I hadn't catered for possibility of a blank column A and no headers on some columns). It could be a tad faster too.

Sub blah()
On Error GoTo exitNicely
Set SceSht = Sheets("Sheet1")
Set oDict = CreateObject("Scripting.Dictionary")
oDict.comparemode = vbTextCompare  'case insensitive
With SceSht
  ServiceColm = Application.Match("service", .Rows(1), 0)
  Hdrs = Application.Transpose(Application.Transpose(.Range(.Cells(1), .Cells(1, ServiceColm))))
  ClientColm = Application.Match("client", Hdrs, 0)
  rowLast = .Cells(.Rows.Count, ClientColm).End(xlUp).Row
  myData = .Range(.Cells(1), .Cells(rowLast, ServiceColm)).Value
End With

myresult = myData  'overkill, I know.
myResultRow = 1
myresult(1, 1) = "Client"
myresult(1, 2) = Hdrs(7)  'myData(1, 7)
myresult(1, 3) = Join(Array(Hdrs(11), Hdrs(12)), ", ")  'Join(Array(myData(1, 11), myData(1, 12)), ", ")
myresult(1, 4) = Hdrs(10)  'myData(1, 10)
myresult(1, 5) = Hdrs(2)  'myData(1, 2)

For rw = UBound(myData) To 2 Step -1
  If Application.Trim(LCase(myData(rw, ServiceColm))) = "patronage" Then
    If Not oDict.exists(Application.Trim(myData(rw, ClientColm))) Then
      myResultRow = myResultRow + 1
      oDict(Application.Trim(myData(rw, ClientColm))) = myResultRow
      myresult(myResultRow, 1) = myData(rw, ClientColm)
      myresult(myResultRow, 2) = myData(rw, 7)
      myresult(myResultRow, 3) = Join(Array(Application.Trim(myData(rw, 11)), Application.Trim(myData(rw, 12))), ", ")
      myresult(myResultRow, 4) = myData(rw, 10)
      myresult(myResultRow, 5) = myData(rw, 2)
    Else
      thatRow = oDict.Item(Application.Trim(myData(rw, ClientColm)))
      myresult(thatRow, 5) = myresult(thatRow, 5) & Chr(10) & myData(rw, 2)
    End If
  End If
Next rw
'write to new sheet:
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(Sheets.Count))
  .Range("A1").Resize(myResultRow, 5).Value = myresult
  .Range("A:E").EntireColumn.AutoFit
  .UsedRange.EntireRow.AutoFit
End With
exitNicely:
Application.ScreenUpdating = True
End Sub

[Lichress]

Thank you very much for your help

[SamT]

p45cal,

I wonder if any of these are working for Lichress.