Slow Macro to sort Multiple Records

[Peter.Stevens2]

I'm having a bit of trouble getting a macro to run. I have a sheet with personnel No's UserID's and Email address as below:

<TABLE style="WIDTH: 488pt; BORDER-COLLAPSE: collapse" cellSpacing=0 cellPadding=0 width=650 border=0 x:str><COLGROUP><COL style="WIDTH: 47pt; mso-width-source: userset; mso-width-alt: 2304" width=63><COL style="WIDTH: 152pt; mso-width-source: userset; mso-width-alt: 7387" width=202><COL style="WIDTH: 58pt; mso-width-source: userset; mso-width-alt: 2816" width=77><COL style="WIDTH: 231pt; mso-width-source: userset; mso-width-alt: 11264" width=308><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; WIDTH: 47pt; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" width=63 height=17>Pers.no.</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 0.5pt solid; BORDER-LEFT: windowtext; WIDTH: 152pt; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" width=202>Communication Type</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 0.5pt solid; BORDER-LEFT: windowtext; WIDTH: 58pt; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" width=77>user ID</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 0.5pt solid; BORDER-LEFT: windowtext; WIDTH: 231pt; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" width=308>E-mail</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000001</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">System user name (SY-UNAME)</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000001</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000001</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">E-mail</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email1</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000011</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">System user name (SY-UNAME)</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000011</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000011</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">E-mail</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email2</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000012</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">System user name (SY-UNAME)</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000012</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000012</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">E-mail</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email3</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000022</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">System user name (SY-UNAME)</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000022</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000022</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">E-mail</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email4</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000023</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">E-mail</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email5</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000024</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">System user name (SY-UNAME)</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000024</TD><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" x:str=""> </TD></TR></TBODY></TABLE>

This is a standard output of some business management sofware I am using and I need to sort the data into the format shown below:

<TABLE style="WIDTH: 144pt; BORDER-COLLAPSE: collapse" cellSpacing=0 cellPadding=0 width=192 border=0 x:str><COLGROUP><COL style="WIDTH: 48pt" span=3 width=64><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; WIDTH: 48pt; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" width=64 height=17>Pers.no.</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 0.5pt solid; BORDER-LEFT: windowtext; WIDTH: 48pt; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" width=64>System user name (SY-UNAME)</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext 0.5pt solid; BORDER-LEFT: windowtext; WIDTH: 48pt; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent" width=64>E-mail</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000001</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000001</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email1</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000011</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000011</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email2</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000012</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000012</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email3</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000022</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000022</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email4</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000023</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent"> </TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">email5</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD class=xl25 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext 0.5pt solid; BORDER-BOTTOM: windowtext 0.5pt solid; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent" height=17>00000024</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent">U000024</TD><TD class=xl24 style="BORDER-RIGHT: windowtext 0.5pt solid; BORDER-TOP: windowtext; BORDER-LEFT: windowtext; BORDER-BOTTOM: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent"></TD></TR></TBODY></TABLE>

I have a sub routine which does this by copying all of the unique values to another sheet and creating an ID of pers.No and communication type. The sub routine then looks for this ID in the List and returns the value of either the email address or the UserID in the correct column. The problem is that I need to do this for 19500 users and the subroutine takes about 25mins to run through the whole procedure. I've attached the code below but I'm quite new to VBA so I'm not sure if there's a more efficient way of processing the data?

Sub FormatManagerEmails()
On Error Resume Next
'Format Ad-Hoc Manager Email Download into Suitable Format
Sheets("ManagersEmail").Select
Range("A1").Select
'define variables
ManRows = Selection.CurrentRegion.Rows.Count
ManRowNum = 2
    Range(Cells(1, 1), Cells(ManRows, 1)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("G1"), Unique:=True
' Add System User Name column Headings
    
    Range("H1").Value = "System user name (SY-UNAME)"
    Range("I1").Value = "E-mail"
'Create COlumn for ID formula to be inserted
    Columns("A:A").Select
    Range("A1").Activate
    Selection.Insert Shift:=xlToRight
    Range("A1").Value = "ID"
    
'Loop to Create ID formula for every Record in Sheet
        For ManRowNum = 2 To ManRows
            Cells(ManRowNum, 1).FormulaR1C1 = "=RC[1]&RC[2]"
        Next ManRowNum
        Columns("A:A").Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False
'Loop to Lookup Manager UserID and Email address
        Range("H2").Select
        
        ManRows = Selection.CurrentRegion.Rows.Count
        ManRowNum = 2
        
        Columns("A:A").Select
        
        
        CommType = "System user name (SY-UNAME)"
        
        For ManRowNum = 2 To ManRows
         
        PersNo = Cells(ManRowNum, 8).Value
        
            Cells(ManRowNum, 9).Value = Selection.Find(What:=PersNo & CommType, LookIn:=xlValues).Offset(0, 3).Value
            
        Next ManRowNum
        
        CommType = "E-mail"
        Range("A1").Activate
        
        For ManRowNum = 2 To ManRows
        
        PersNo = Cells(ManRowNum, 8).Value
        
            Cells(ManRowNum, 10).Value = Selection.Find(What:=PersNo & CommType, LookIn:=xlValues).Offset(0, 4).Value
            
        Next ManRowNum

End Sub

Any Help would be greatly appreciated! ray:

Thanks

 

[nigelk]

Here's a small macro that might help. It works on the sample you gave and the results match what you want.

All it does it check to see if some condition are met. For example, if the value in in B7 is the same as B6 then the pers number is the same.

Then it checks to see if the range E6 is empty, if so, copy the value from E7 into E6 and then deletes the original row. Then all you have to do is delete "communication type" column.

If you can't alter the main data, just make a copy on another sheet and then run the macro

Does that make sense?

Anyway, hope it helps.



manrow = Cells(65536, 2).End(xlUp).Row

For x = manrow To 2 Step -1

If Cells(x, 2) = Cells(x - 1, 2) And Cells(x - 1, 5) = "" Then
Cells(x - 1, 5) = Cells(x, 5)

Rows(x & ":" & x).Delete
End If
Next


End Sub

 

[tusharm]

In using the Advanced Filter, you had the right idea in using Excel's capabilities to do your work. But, then, you fell back on the primitive VBA loop coupled with the Find. Instead, let Excel do all the work for you. Construct an array formula that returns the result you want and copy that result down the rows.

Given your original data layout in A:D, and the unique Pers.No. in H:

In I2 enter the array formula =IFERROR(INDEX($C$2:$C$11,MAX(ROW($A$2:$A$11)*($B$2:$B$11="system user name (sy-uname)")*($A$2:$A$11=H2))-1),"")
In J2 enter the array formula =IFERROR(INDEX($D$2:$D$11,MAX(ROW($A$2:$A$11)*($B$2:$B$11="e-mail")*($A$2:$A$11=H2))-1),"")

Now, copy I2:J2 as far down as needed. The code below does just that.

If you are not using Excel 2007, you will have to replace the IFERROR() with the much more cumbersome =IF(ISERROR(INDEX(...)),"",INDEX(....))

Obviously, once done, you can copy and paste values if that's what you want.

Option Explicit

Sub Macro1()
    Dim SrcRng As Range, DestRng As Range
    Set SrcRng = Range(Range("A1"), Range("a1").End(xlDown))
    SrcRng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
    Set DestRng = Range(Range("h1"), Range("h1").End(xlDown))
    Application.CutCopyMode = False
    Range("C1:D1").Copy Range("I1")
    Application.CutCopyMode = False
    Set DestRng = DestRng.Offset(1, 0).Resize(DestRng.Rows.Count - 1)
    'We cannot use the fastest way to add a formula because we want each cell to have an independent array formula _
    DestRng.Offset(0, 1).FormulaArray = _
        "=IFERROR(INDEX(R2C3:R11C3,MAX(ROW(R2C1:R11C1)*(R2C2:R11C2=""system user name (sy-uname)"")*(R2C1:R11C1=RC[-1]))-1),"""")" _
    DestRng.Offset(0, 2).FormulaArray = _
        "=IFERROR(INDEX(R2C4:R11C4,MAX(ROW(R2C1:R11C1)*(R2C2:R11C2=""e-mail"")*(R2C1:R11C1=RC[-2]))-1),"""")" _
    Instead, we add the array formulas to the 1st row and then copy that row down.
    DestRng.Offset(0, 1).Resize(1, 1).FormulaArray = _
        "=IFERROR(INDEX(R2C3:R11C3,MAX(ROW(R2C1:R11C1)*(R2C2:R11C2=""system user name (sy-uname)"")*(R2C1:R11C1=RC[-1]))-1),"""")"
    DestRng.Offset(0, 2).Resize(1, 1).FormulaArray = _
        "=IFERROR(INDEX(R2C4:R11C4,MAX(ROW(R2C1:R11C1)*(R2C2:R11C2=""e-mail"")*(R2C1:R11C1=RC[-2]))-1),"""")"
    DestRng.Offset(0, 1).Resize(1, 2).Copy DestRng.Offset(1, 1).Resize(DestRng.Rows.Count - 1)
    End Sub

 

[Fazza]

Hi, Peter. Regards, Fazza

Sub should_be_faster()
 
  Dim i As Long, j As Long
  Dim arIn() As Variant
  Dim arOut() As Variant
 
  With Range("A1").CurrentRegion
    ReDim arIn(1 To .Rows.Count + 1, 1 To .Columns.Count)
    arIn = .Resize(.Rows.Count + 1).Value
  End With 
  ReDim arOut(1 To UBound(arIn, 1), 1 To 3)
 
  j = 1
  'Headers
  arOut(j, 1) = arIn(1, 1)
  arOut(j, 2) = arIn(1, 3)
  arOut(j, 3) = arIn(1, 4)
 
  For i = 2 To UBound(arOut, 1) - 1
    If Not arIn(i, 1) = arIn(i - 1, 1) Then
      j = j + 1
      arOut(j, 1) = arIn(i, 1)
      arOut(j, 2) = arIn(i, 3)
      If Len(arIn(i, 4)) > 0 Then
        arOut(j, 3) = arIn(i, 4)
      Else
        arOut(j, 3) = arIn(i + 1, 4)
      End If
    End If
  Next i
 
  With Range("F1")
    .Resize(, 3).EntireColumn.ClearContents
    .Resize(j, 3).Value = arOut
  End With
End Sub

 

[Peter.Stevens2]

Wow, didn't expect such a prompt response!! Many Thanks all for your suggestions, I'll give them a try. (might take me a while to get my primitive VB mind around them though!! )

Tusharm, am I right in thinking that I will need to modify the ArrayFormulas to include all of my records (circa 19500 records)?

Fazza, I tried copying your macro into a new sheet and running it and it was very quick. The only thing was that if a pers.no. doesn't have a UserID then the previous Email address is input and not their own email. unfortunately the data I am working with is inconsistent and some Pers. No's don't have Email Address' and some don't have User ID's.

Thanks Again for all your help its certainly been an eye opener!!

 

[Fazza]

Fazza, I tried copying your macro into a new sheet and running it and it was very quick. The only thing was that if a pers.no. doesn't have a UserID then the previous Email address is input and not their own email. unfortunately the data I am working with is inconsistent and some Pers. No's don't have Email Address' and some don't have User ID's.

It was excellent, Peter, that you posted some sample data and the corresponding results initially. It is a big help to everyone.

The code I posted worked OK on the sample data. For the data it doesn't work on, can you post an example? It should be easy enough to have the code do what is required. It is just a matter of understanding the structure of the data and coding to suit. Regards, Fazza

 

[Fazza]

Hi,

I tried a rather different approach and it seems OK: the SQL maybe could be done more efficiently, but I'm still learning.

Can still change the previous approach later if required.

regards, Fazza

Sub using_ADO()
 
  Dim i As Long
  Dim strConn As String
  Dim strSQL As String
  Dim objRS As Object
 
  'Can't have "." in header names
  Range("A1").Value = "Pers_no"
  Range("A1").CurrentRegion.Name = "MyData"
  'clear results range
  Range("F1").Resize(, 3).EntireColumn.Clear
 
  strConn = Join$(Array("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=", _
      ActiveWorkbook.FullName, ";Extended Properties=""Excel 8.0;"""), vbNullString)
 
  strSQL = Join$(Array( _
      "SELECT A.Pers_no, B.`user ID`, C.`E-mail`", _
      "FROM ", _
      "(SELECT DISTINCT Pers_no FROM MyData) A,", _
      "(SELECT Pers_no, Max(`user ID`) AS [user ID] FROM MyData GROUP BY Pers_no) B,", _
      "(SELECT Pers_no, Max(`E-mail`) AS [E-mail] FROM MyData GROUP BY Pers_no) C", _
      "WHERE A.Pers_no=B.Pers_no AND A.Pers_no=C.Pers_no"), vbCr)
 
  Set objRS = CreateObject("ADODB.Recordset")
  With objRS
    .Open strSQL, strConn
    Cells(2, 6).CopyFromRecordset objRS
    For i = 0 To .fields.Count - 1
      Cells(1, i + 6).Value = .fields(i).Name
    Next i
    .Close
  End With
  Set objRS = Nothing
End Sub

 

[Fazza]

Actually, I'm not sure about if that second approach gives the right result. Need to double check, and I can't do that til tomorrow. It is a slower approach anyway.

 

[jindon]

try

Sub test()
Dim a, b(), i As Long, ii As Long, n As long
With Range("a1").CurrenRegion.Resize(,4)
    a = .Value
    ReDim b(1 To UBound(a,1), 1 To UBound(a,2))
    n = 1
    b(n,1) = "Pers.No,": b(n,2) = a(2,2) :b(n,3) = "E-Mail"
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a,1)
            If Not IsEmpty(a(i,1)) Then
                If Not .Exists(a(i,1)) Then
                    n = n + 1 : b(n,1) = a(i,1) : .add a(i,1), n
                End If
                For ii = 3 To UBound(a,2)
                    If a(i,ii) <> "" Then b(.item(a(i,1)), ii-1) = a(i,ii)
                Next
            End If
        Next
    End With
    .Value = b
End With
End Sub

 

[Fazza]

Whilst travelling home I had another thought. Untested.

Sub using_ADO()
 
  Dim i As Long
  Dim strConn As String
  Dim strSQL As String
  Dim objRS As Object
 
  'Can't have "." in header names
  Range("A1").Value = "Pers_no"
  Range("A1").CurrentRegion.Name = "MyData"
  'clear results range
  Range("F1").Resize(, 3).EntireColumn.Clear
 
  strConn = Join$(Array("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=", _
      ActiveWorkbook.FullName, ";Extended Properties=""Excel 8.0;"""), vbNullString)
 
  strSQL = Join$(Array( _
      "SELECT Pers_no, Max(`user ID`) AS [user ID], Max(`E-mail`) AS [E-mail]", _
      "FROM MyData", _
      "GROUP BY Pers_no"), vbCr)
 
  Set objRS = CreateObject("ADODB.Recordset")
  With objRS
    .Open strSQL, strConn
    Cells(2, 6).CopyFromRecordset objRS
    For i = 0 To .fields.Count - 1
      Cells(1, i + 6).Value = .fields(i).Name
    Next i
    .Close
  End With
  Set objRS = Nothing
End Sub