Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > microsoft.public.excel.programming > #108287

Re: Query for Macro

Show all headers | View raw

Hi Mandeep,

Am Sun, 6 Dec 2015 23:09:51 -0800 (PST) schrieb Mandeep Baluja:

> This is something amazing,Gud work Logic was same but the use of array is brilliantly done !!! 
> For i = LBound(varData) To UBound(varData)
>           key = varData(i, 1) & "," & varData(i, 2) & "," _
>               & varData(i, 3) & "," & varData(i, 4)
>            If Not myDic.Exists(key) Then
 >              myDic(key) = i
>                ReDim Preserve varOut(j)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
>                varOut(j) = key
>                j = j + 1
>            End If^

at the position above the array varOut is superfluous.
Try it this way:

Sub Test()
Dim varData As Variant, varOut() As Variant
Dim varTmp() As Variant, varTmp2 As Variant
Dim i As Long, j As Long, k As Long, LRow As Long
Dim myDic As Object, myDic2 As Object
Dim key As String, myStr As String
Dim st As Double
st = Timer

Application.ScreenUpdating = False
Sheets("Sheet2").UsedRange.ClearContents

With Sheets("Sheet1")
    LRow = .Cells(Rows.Count, 1).End(xlUp).Row
    If myDic Is Nothing Then _
        Set myDic = CreateObject("Scripting.Dictionary")
        varData = .Range("A1:D" & LRow)
        For i = LBound(varData) To UBound(varData)
            key = varData(i, 1) & "," & varData(i, 2) & "," _
                & varData(i, 3) & "," & varData(i, 4)
            If Not myDic.Exists(key) Then
                myDic(key) = i
            End If
        Next
    
    varTmp = myDic.keys
    
    ReDim Preserve varOut(UBound(varTmp), 3)
    For i = LBound(varTmp) To UBound(varTmp)
        For j = 0 To 3
            varOut(i, j) = Split(varTmp(i), ",")(j)
        Next
    Next
        
    If myDic2 Is Nothing Then _
        Set myDic2 = CreateObject("Scripting.Dictionary")
    For i = LBound(varOut) To UBound(varOut)
        key = varOut(i, 0)
        If Not myDic2.Exists(key) Then
            myDic2(key) = i
        End If
    Next
    
    varTmp2 = myDic2.keys
    Sheets("Sheet2").Range("A1").Resize(UBound(varTmp2) + 1) = _
        Application.Transpose(varTmp2)
        
    For j = 1 To 3
        For k = LBound(varTmp2) To UBound(varTmp2)
            For i = LBound(varOut) To UBound(varOut)
                If varOut(i, 0) = varTmp2(k) Then
                    If myStr = "" Then myStr = varOut(i, j)
                    If InStr(myStr, varOut(i, j)) = 0 Then myStr = myStr
& ", " & varOut(i, j)
                End If
            Next
            Sheets("Sheet2").Cells(k + 1, j + 1) = myStr
            myStr = ""
        Next
    Next
End With
Sheets("Sheet2").Columns("A:D").AutoFit
Application.ScreenUpdating = True
MsgBox Format(Timer - st, "0.000")
End Sub



Regards
Claus B.
-- 
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Back to microsoft.public.excel.programming | Previous | Next — Previous in thread | Find similar | Unroll thread

Thread

Query for Macro Mandeep Baluja <rockernayal@gmail.com> - 2015-12-03 03:35 -0800
  Re: Query for Macro Claus Busch <claus_busch@t-online.de> - 2015-12-03 15:28 +0100
  Re: Query for Macro Mandeep Baluja <rockernayal@gmail.com> - 2015-12-03 10:06 -0800
    Re: Query for Macro Claus Busch <claus_busch@t-online.de> - 2015-12-03 19:43 +0100
      Re: Query for Macro Claus Busch <claus_busch@t-online.de> - 2015-12-03 19:47 +0100
        Re: Query for Macro Mandeep Baluja <rockernayal@gmail.com> - 2015-12-03 21:17 -0800
          Re: Query for Macro Claus Busch <claus_busch@t-online.de> - 2015-12-04 19:45 +0100
            Re: Query for Macro Mandeep Baluja <rockernayal@gmail.com> - 2015-12-06 23:09 -0800
              Re: Query for Macro Claus Busch <claus_busch@t-online.de> - 2015-12-07 15:32 +0100

csiph-web