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ą