PDA

View Full Version : acceleration of a macros formation of data on new sheet



Lichress
02-27-2017, 07:40 AM
Hi, please, look whether it is possible to accelerate action of a macros?

SamT
02-27-2017, 07:03 PM
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
02-27-2017, 07:13 PM
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.R ows(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
02-27-2017, 07:56 PM
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
02-28-2017, 09:08 AM
Thank you very much for your help

SamT
02-28-2017, 12:17 PM
p45cal,

I wonder if any of these are working for Lichress.