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

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

Re: Query for Macro

Show all headers | View raw

Hi Mandeep,

Am Thu, 3 Dec 2015 21:17:04 -0800 (PST) schrieb Mandeep Baluja:

> Output :- 
> 1, 2	a, b, d	c, d, e, f, g	k, B, T
> 
> But i want is :- 
> 1	b,a,d	d,e,f,g	B,T     k,b,t
> 2	a,b,d	c,d,e,f,g	k,B,T

now I got it ;-)
Try this (a little bit faster than your code):

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

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
                ReDim Preserve varOut(j)
                varOut(j) = key
                j = j + 1
            End If
        Next
    
    ReDim Preserve varTmp(UBound(varOut), 3)
    For i = LBound(varOut) To UBound(varOut)
        For j = 0 To 3
            varTmp(i, j) = Split(varOut(i), ",")(j)
        Next
    Next
        
    If myDic2 Is Nothing Then _
        Set myDic2 = CreateObject("Scripting.Dictionary")
    For i = LBound(varTmp) To UBound(varTmp)
        key = varTmp(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(varTmp) To UBound(varTmp)
                If varTmp(i, 0) = varTmp2(k) Then
                    If myStr = "" Then myStr = varTmp(i, j)
                    If InStr(myStr, varTmp(i, j)) = 0 Then myStr = myStr
& ", " & varTmp(i, j)
                End If
            Next
            Sheets("Sheet2").Cells(k + 1, j + 1) = myStr
            myStr = ""
        Next
    Next
End With
Sheets("Sheet2").Columns("A:D").AutoFit
End Sub

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

Back to microsoft.public.excel.programming | Previous | Next — Previous in thread | Next 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