super :)
aciu



"Laimis"  wrote in message news:mstdf4$1sk$1@trimpas.omnitel.net...

BURRIS rašė:
> dar šiek tiek prie to pačio excel.
> nepastebėjau kad yra vienodų kodų ir skirtingų barkodų tam pačiam kodui:
> POP99011CBR    325 10 BG2
> POP99011CBR    4587DR
> POP99011CBR    8031006020312
> POP99011CBR    GD4587DR
> POP99011CBR    HF-OP11012-G1
> POP99011CBR    OP08-000G-A1
> POP99011CBR    OP080000G-1R00
> POP99011CBR    OP99016CAR
> POP99011CBR    POP99011CBR
> POP99011CBR    UOE04-34312
>
> ar galima kaip nors tuos barkodus sukisti i viena cele skiriant tuos
> kabliataskiu? nes dabar atkelia tik pirma barkoda.


VBA Tools->References reikia pridėti Microsoft ActiveX Data Objects 2.x
Library.


VBA modulio kodas:
--

Public bUpdate As Boolean
Public rngDest As Range
Public rstDest As ADODB.Recordset

Public Function Process(rng As Range) As String
     Dim sDataAddr As String
     Dim cnn As ADODB.Connection
     Dim rst As ADODB.Recordset
     'Dim rstDest As ADODB.Recordset
     Dim sCode As String
     Dim colList As Collection

     sDataAddr = "[" & rng.Parent.Name & "$" & _
         rng.Address(RowAbsolute:=False, ColumnAbsolute:=False) & "]"

     Set cnn = New ADODB.Connection
     With cnn
         .Provider = "Microsoft.Jet.OLEDB.4.0"
         .ConnectionString = _
             "Data Source='" & Application.ActiveWorkbook.FullName &
"';" & _
             "Extended Properties='Excel 8.0;HDR=no';"
         .Open
     End With


     Set rst = New ADODB.Recordset
     With rst
         .ActiveConnection = cnn
         .CursorLocation = adUseClient
         .CursorType = adOpenStatic
         .LockType = adLockReadOnly
         .Open Source:="SELECT * FROM " & sDataAddr & " ORDER BY 1,2"
     End With

     Set rstDest = New ADODB.Recordset
     With rstDest
         .ActiveConnection = Nothing
         .CursorType = adOpenKeyset
         .CursorLocation = adUseClient

         .Fields.Append "Code", adVarWChar, 255
         .Fields.Append "List", adVarWChar, 255

         .Open
     End With

     Do While Not rst.EOF
         sCode = rst.Fields(0).Value
         Set colList = New Collection

         Do While sCode = rst.Fields(0).Value
             colList.Add rst.Fields(1).Value
             rst.MoveNext

             If rst.EOF Then Exit Do
         Loop

         With rstDest
             .AddNew
             .Fields("Code").Value = sCode
             .Fields("List").Value = Join(Col2Arr(colList), "; ")
             .Update
         End With
     Loop

     rstDest.MoveFirst
     Set rngDest = Application.Caller.Offset(0, 1)
     'ActiveCell.CopyFromRecordset rstDest
     bUpdate = True
     Process = rng.Address

     rst.Close
     Set rst = Nothing

     cnn.Close
     Set cnn = Nothing

End Function

Public Function Col2Arr(col As Collection)
     Dim arr() As String
     ReDim arr(1 To col.Count) As String
     For i = 1 To col.Count
         arr(i) = col(i)
     Next
     Col2Arr = arr
End Function


WorkBook'o kodas:
--
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)

     If Not bUpdate Then Exit Sub

     bUpdate = False
     rngDest.CopyFromRecordset rstDest

End Sub

O tada worksheet'e kvieti funkciją =Process(range), kur range yra
apdorojamų duomenų sritis iš dviejų stulpelių: pirmas — kodas (pagal
kurį grupuojama), antras — barkodai (kuriuos reikia sutraukti į eilutę)

Šalia tos funkcijos įterpimo (vienu langeliu dešiniau) bus išvestas
rezultatas.

Prikabinu ir excel'io failą