Arvot listaksi

Tällä kertaa teinkin collection objektilla , koska se herjaa jos lisää tupla-arvon ja sitä hyödynsin ;-), eli koodi on tosi simppeli


moduuliin...
Option Explicit
Dim cl As Range
Dim cainoa As Collection
Dim i As Long
Dim uList() As Variant
Dim ws As Worksheet
Dim TäytäLista As Variant

Sub Uniikit()
On Error Resume Next
Application.ScreenUpdating = False
Set cainoa = New Collection
For Each ws In ThisWorkbook.Worksheets
' muuta haettava taulukon nimi sopivaksi ja kirjainten määrä nimen alusta(ISOLLA KIRJAIMILLA) nyt PELI ja 4 ekaa kirjainta
If UCase(Left(ws.Name, 4)) = "PELI" Then
' muuta haettavat sarakeet sopivaksi
ws.Activate
Union(ws.Range("F:F"), ws.Range("J:J"), ws.Range("N:N"), ws.Range("R:R"), ws.Range("V:V")).SpecialCells(xlCellTypeConstants, 23).Select
For Each cl In Selection
If cl.Value <> "" And Not Left(cl.Value, 1) = "(" Then
cainoa.Add cl.Value, CStr(cl.Value)
End If
Next cl
ws.Range("F1").Select
End If
Next
TäytäLista = ""
If cainoa.Count > 0 Then
ReDim uList(1 To cainoa.Count)
For i = 1 To cainoa.Count
uList(i) = cainoa(i)
Next i
TäytäLista = Application.WorksheetFunction.Transpose(uList)
End If

'kopioi uniikit A sarakkeeseen, muuta alue ja taulukon nimi sopiviksi
Worksheets("Koonti").Activate
Range("A:A") = ""
Range("A1").Resize(cainoa.Count) = TäytäLista
Range("A1").Select
Application.ScreenUpdating = True
On Error GoTo 0
End Sub

ThisWorkbook (TämäTyökirja) moduuliin...

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "Koonti" Then Exit Sub
If Not Intersect(Union(Range("F:F"), Range("J:J"), Range("N:N"), Range("R:R"), Range("V:V")), Target) Is Nothing Then
Uniikit
End If
End Sub

Keep EXCELing
@Kunde

Olipa tosiaan simppeli, heh... on se helppoa, jos osaa. Kiitoksia avusta.
Yksi isompi ja yksi pienempi ongelma vielä on, vaikka tästä oli tosiaan jo minulle paljon apua.

Kun tekee jotain muutoksia noihin kohteena oleviin sarakkeisiin, niin lista päivittyy sinne koonti-sivulle ihan kuten halusinkin, mutta se koontisivu jää sitten aina näkyviin. Jos teen vaikkapa sinne peli_jokin -taulukkoon 10 muutosta putkeen, niin joutuu 9 kertaa palaamaan siihen takaisin, kun joka välissä joutuu siihen koonti-taulukkoon. Jos muutos on sellainen, että poistan jotain ja kirjoitan jotain tilalle, tuo koontiin heittäminen tapahtuu itse asiassa kahdesti. Voiko tuota fiksata siten, että muutoksen tehtyäni pysyisin edelleen siellä, minne sen muutoksen olen tehnyt, ja se koonti vain päivittyisi niin, että voin käydä sitä katsomassa sitten, kun sen listan haluan nähdä?

Toinen juttu on, että tuo ei jotenkin hyväksy arvojen siirtelyä noiden sarakkeiden sisällä. Jos vaikka solussa F3 lukisi "test" ja F4 on tyhjä, ja haluan siirtää sen "test"-sanan soluun F4, niin onnistuu siten, että tyhjennän F3:n ja kirjoitan F4:ään, mutta ei onnistu raahaamalla eikä cut-paste -menetelmällä, vaan tulee "Run-time error 1004: Method 'intersect' of object '_Global' failed". Copy-paste kyllä toimii. Tämähän ei ole iso ongelma, kun sen voi helposti kiertää, kun vain muistaa.

Mikä EXCEL versio käytössä?
Mulla kyllä voi raahata kopioida ja leikata ihan normaalisti (v.2010)
muuta koodissa loppuosa


Sub Uniikit()
On Error Resume Next
Application.ScreenUpdating = False
Set cainoa = New Collection
For Each ws In ThisWorkbook.Worksheets
' muuta haettava taulukon nimi sopivaksi ja kirjainten määrä nimen alusta(ISOLLA KIRJAIMILLA) nyt PELI ja 4 ekaa kirjainta
If UCase(Left(ws.Name, 4)) = "PELI" Then
' muuta haettavat sarakeet sopivaksi
ws.Activate
Union(ws.Range("F:F"), ws.Range("J:J"), ws.Range("N:N"), ws.Range("R:R"), ws.Range("V:V")).SpecialCells(xlCellTypeConstants, 23).Select
For Each cl In Selection
If cl.Value <> "" And Not Left(cl.Value, 1) = "(" Then
cainoa.Add cl.Value, CStr(cl.Value)
End If
Next cl
ws.Range("F1").Select
End If
Next
TäytäLista = ""
If cainoa.Count > 0 Then
ReDim uList(1 To cainoa.Count)
For i = 1 To cainoa.Count
uList(i) = cainoa(i)
Next i
TäytäLista = Application.WorksheetFunction.Transpose(uList)
End If

'kopioi uniikit A sarakkeeseen, muuta alue ja taulukon nimi sopiviksi
Worksheets("Koonti").Range("A:A") = ""
Worksheets("Koonti").Range("A1").Resize(cainoa.Count) = TäytäLista
Worksheets("Koonti").Range("A1").Select
Application.ScreenUpdating = True
On Error GoTo 0
End Sub

Keep EXCELing
@Kunde

unohtui tää toinen koodi...

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "Koonti" Then Exit Sub
If Not Application.Intersect(Union(Range("F:F"), Range("J:J"), Range("N:N"), Range("R:R"), Range("V:V")), Target) Is Nothing Then
Uniikit
Sh.Activate
End If
End Sub

Molemmat ongelmat hävisivät. 2016 tuo versio on, vaikkei sillä enää liene väliä, mutta vastaanpa kuitenkin kysymykseen. Kiitos taas.