Keskustelu: Ohjelmointikysymykset: VBA: Kuinka hypätä aina kolumnin yli?

butterfly [11.12.2007 14:17:12]

Hei kaikki. löysin täältä selailemalla apua ongelmaani. löysin siis tällasen koodin jonka varmaan saisin toimiin omaanki juttuuni, mut sitte on sellanen probleema, että kuinka saa ton jutun hyppään aina tietyn määrän kolumneja yli jos vaikka välissä on aina sellasia, jota ei tarvis eli et se kopiois joka loopilla kolumnista A ja sitten joka kolmannen kolumnin jutut.

Sub Hakua()
    Dim i As Long, C As Range, S1 As String, S2 As String
    S1 = "Sheet1"
    S2 = "Sheet2"
    i = 16
    Do Until Sheets(S1).Cells(i, "A").Value = ""
        With Sheets(S2)
        For Each C In .Range(.Cells(1, 1), .Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row, .Cells.SpecialCells(xlCellTypeLastCell).Column))
            If C.Value = Sheets(S1).Cells(i, "A").Value Then
                Sheets(S1).Cells(i, C.Column) = .Cells(C.Row, C.Column).Value
                Sheets(S1).Cells(i, C.Column + 1) = .Cells(C.Row, C.Column + 1).Value
            End If
        Next
        End With
        i = i + 1
    Loop
End Sub

neau33 [12.12.2007 11:16:01]

Heippa butterfly!

the viritelmä...

'ThisWorkbook
Private Sub Workbook_Open()
  Sheets(1).CommandButton1.Visible = True
End Sub

'Taul1 - Nappi
Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  haku
End Sub

Private Sub haku()
  Dim i As Long, solu
  i = 1 '[k]haku alkaa riviltä 1[/k]
  Application.ScreenUpdating = False
  Do Until Sheets(1).Cells(i, "A").Value = ""
    With Sheets(2)
      For Each solu In .Range("A1:" & _
      Replace(.Cells.SpecialCells(xlCellTypeLastCell).Address, "$", ""))
        If solu.Value = Sheets(1).Cells(i, "A").Value Then
          Select Case .Cells(1, solu.Column).Text
            Case "Mortti", "Pertti", "Vertti" ', jne...
              '[k]ei tehdä mitään...[/k]
            Case Else
              Sheets(1).Cells(i, solu.Column) = _
              .Cells(solu.Row, solu.Column).Value
          End Select
        ' [k]tai esim.[/k]
        ' Select Case solu.Column
        '   Case 1, 4 To 6 'jne...
        '      '[k]ei tehdä mitään...[/k]
        '   Case Else
        '     Sheets(1).Cells(i, solu.Column) = _
        '     .Cells(solu.Row, solu.Column).Value
        ' End Select
        End If
      Next
    End With
    i = i + 1
  Loop
   'poista_sarakkeet '[k](tyhjät sarakkeet pois välistä...)[/k]
   CommandButton1.Visible = False
  Application.ScreenUpdating = True
End Sub

Private Sub poista_sarakkeet()
  Dim sarake As String, solu, i As Integer, sarakkeet As String
  With Sheets(1)
    sarake = _
    Replace(Sheets(2).Cells.SpecialCells _
   (xlCellTypeLastCell).Address, "$", "")
    For i = 1 To Len(sarake)
      If IsNumeric(Mid(sarake, i, 1)) Then _
      sarake = Left(sarake, i - 1): Exit For
    Next i
    For Each solu In .Range("A1:" & sarake & "1")
      If IsEmpty(solu) Then
        Dim xsolu, xsarake() As String
        tyhjää = True
        xsarake = Split(solu.Address, "$")
        Range(xsarake(1) & "1:" & xsarake(1) & _
        CStr(Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row)) _
        .Select
        If IsEmpty(RangeSelection) Then
          sarakkeet = sarakkeet & xsarake(1) & ":" & xsarake(1) & ","
        End If
      End If
    Next
    If Not IsEmpty(sarakkeet) Then
      sarakkeet = Left(sarakkeet, Len(sarakkeet) - 1)
      .Range(sarakkeet).Select
       Selection.Delete
      .Range("A1").Select
    End If
    Erase xsarake
  End With
End Sub

neau33 [13.12.2007 09:46:35]

Moikka taas butterfly!

tässä ehkä hieman elegantimpi versio samasta paskasta...

Taul1

OTSIKOT     |
1. jutska   |
2. jutska   |
3. jutska   |
4. jutska   |
5. jutska   |
6. jutska   |
7. jutska   |
8. jutska   |
9. jutska   |
10. jutska  |

Taul2

OTSIKOT     |   Maija | Matti | Lasse | Liisa | Vieno | Viljo |
1. jutska   |   11    | 21    | 31    | 41    | 51    | 61    |
2. jutska   |   12    |	22    |	32    |	42    |	52    |	62    |
3. jutska   |   13    |	23    |	33    |	43    |	53    |	63    |
4. jutska   |   14    |	24    |	34    |	44    |	54    |	64    |
5. jutska   |   15    |	25    |	35    |	45    |	55    |	65    |
6. jutska   |   16    |	26    |	36    |	46    |	56    |	66    |
7. jutska   |   17    |	27    |	37    |	47    |	57    |	67    |
8. jutska   |   18    |	28    |	38    |	48    |	58    |	68    |
9. jutska   |   19    |	29    |	39    |	49    |	59    |	69    |
10. jutska  |   20    |	30    |	40    |	50    |	60    |	70    |

VB-koodi

'ThisWorkbook
Private Sub Workbook_SheetBeforeDoubleClick(ByVal _
Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If Not UserForm1.Visible Then UserForm1.Show
End Sub

'UserForm1
'[k]formille: ListBoxi & nappi
'käyttö: tuplaklikkaa taulua & anna palaa...[/k]
Dim solu, alue

Private Sub UserForm_Initialize()
  Me.Caption = "Tuo valitut..."
  Me.Width = 151: Me.Height = 151
  ListBox1.Width = 130: ListBox1.Height = 80
  ListBox1.Top = 10: ListBox1.Left = _
  (Me.Width - ListBox1.Width) / 2 - 3
  CommandButton1.Width = 50
  CommandButton1.Height = 18
  CommandButton1.Left = _
  (Me.Width - CommandButton1.Width) / 2 - 3
  CommandButton1.Top = Me.Height _
  - (CommandButton1.Height * 3.3)
End Sub

Private Sub UserForm_Activate()
  Dim pText As Boolean
  Application.ScreenUpdating = False
  ListBox1.Clear
  Sheets(2).Activate
  alue = "A1:" & _
  Replace(Cells.SpecialCells( _
  xlCellTypeLastCell).Address, "$", "")
  Dim splitti() As String
  splitti = Split(alue, ":")
  For i = 1 To Len(splitti(1))
    If IsNumeric(Mid(splitti(1), i, 1)) Then
       splitti(1) = Left(splitti(1), i - 1): Exit For
    End If
  Next i
  For Each solu In Range("A1:" & splitti(1) & "1")
    pText = True
    For i = 1 To Len(solu.Text)
      If IsNumeric(Mid(solu.Value, i, 1)) Or _
        solu.Text = "OTSIKOT" Then
        pText = False: Exit For
      End If
    Next i
    If pText Then _
    ListBox1.AddItem solu.Value
  Next
  If ListBox1.ListCount > 0 Then
    ListBox1.ListStyle = fmListStyleOption
    ListBox1.MultiSelect = fmMultiSelectMulti
    For i = 2 To Sheets(2).Cells. _
    SpecialCells(xlCellTypeLastCell).Column
      For j = 0 To ListBox1.ListCount - 1
        If Sheets(1).Cells(1, i).Value = _
         ListBox1.List(j) Then
             ListBox1.Selected(j) = True
        End If
      Next j
    Next i
  End If
  Sheets(1).Activate
  Application.ScreenUpdating = True
End Sub

Private Sub CommandButton1_Click()
  Application.ScreenUpdating = False
  haku
  poista_sarakkeet
  Application.ScreenUpdating = True
End Sub

Sub haku()
  Dim valinta As Boolean
  Sheets(1).Activate
    Range("B1:" & Sheets(2).Cells. _
    SpecialCells(xlCellTypeLastCell).Address).Select
    Selection.Clear
    For Each solu In Sheets(2).Range(alue)
      If Cells(solu.Row, 1).Value = _
      Sheets(2).Cells(solu.Row, 1).Value Then
      For i = 0 To ListBox1.ListCount - 1
        valinta = False
        If ListBox1.List(i) = Sheets(2).Cells(1, solu.Column).Text _
        And ListBox1.Selected(i) Then
          valinta = True: Exit For
        End If
      Next i
        Select Case valinta
          Case False
          '[k]ei tapahtumaa...[/k]
          Case Else
            Cells(solu.Row, solu.Column).Value = solu.Value
        End Select
       End If
     Next
End Sub

Sub poista_sarakkeet()
  Dim sarake As String, solu, sarakkeet As String
  With Sheets(1)
    sarake = _
    Replace(Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Address, "$", "")
    For i = 1 To Len(sarake)
      If IsNumeric(Mid(sarake, i, 1)) Then _
      sarake = Left(sarake, i - 1): Exit For
    Next i
    For Each solu In .Range("B1:" & sarake & "1")
      If IsEmpty(solu) Then
        Dim xsolu, xSarake() As String
        tyhjää = True
        xSarake = Split(solu.Address, "$")
        Range(xSarake(1) & "1:" & xSarake(1) & _
        CStr(Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row)) _
        .Select
        If IsEmpty(RangeSelection) Then
          sarakkeet = sarakkeet & xSarake(1) & ":" & xSarake(1) & ","
        End If
      End If
    Next
    If Len(sarakkeet) > 1 Then
      sarakkeet = Left(sarakkeet, Len(sarakkeet) - 1)
      .Range(sarakkeet).Select
      Selection.Delete
      Cells(1, 1).Activate
    End If
  End With
  Erase xSarake
End Sub

butterfly [13.12.2007 10:05:50]

Kiitos Nea. Kokeilen ja yritän ymmärtää tuota jutskaa. Katsotaan saanko toimimaan.

butterfly [13.12.2007 10:42:32]

Hei taas. Katselin tuota koodia ja sain sen tekemään kummia. Ehkä täytyy selittää ongelmani paremmin. Yritän tehdä apuvälineeks (huonolla menestyksellä siis, enemmän hommaa tässä on kun käsin kirjoittamisessa, mutta mielenkiintoista) sellasta taulukko systeemiä mihin saatais lasten urheilu suoritukset järjesteltyä.

Taulukko1

          Juoksu1            pituus1:             pallonheitto1      juoksu2
Nimi:   | sijoitus:| aika | sijoitus | pituus | sijoitus: | pituus | sijoitus |
Anni    |
Kaisu   |
Venla   |
Riikka  |
Annika  |
Ronja   |
Ville   |
Roni    |
Samu    |
Erik    |
Juuso   |
Viljami |

Taulukkoon 2 olen laittanu aina esimerkiks tähän malliin

   juoksu1           pituus:
1 | Venla | 1,34,5 | Ville  |
2 | Juuso | 1,35,2 | Ronja
3 | Anni  | 1,36,1 | Roni
4 | Roni  |        | Samu
5 | Samu  | 1,40,2 |
6 | Annika
7 | Ronja
8 | Ville
9 | Viljami
10| Erik
11| Kaisu
12| Riikka

Ajattelin vaan että tarviiko kirjoittaa aina tuo sijoitus tuonne väliin vai saako sen aina tuosta kolumnista A ja jos ei ole ollut paikalla ja suorituksena on tyhjä niin että vaan hyppäis seuraavaan ja voiko juoksu ajan ja pituus sijoituksen väliin tulla tyhjä sarake että on helpompaa pitää kirjaa.

Ehkä tämä meni hieman yli osaamiseni, mutta kiitos avusta kuitenkin.

neau33 [13.12.2007 14:31:05]

Heippa taas butterfly!

Hieno homma, että lähdit välittömästi tutkimaan mitä tapahtuu jos...
sit kysymykseesi: mikä/mitkä tahansa vertailu arvo/t on haettavissa minkä tahansa taulun mistä tahansa solusta/soluista eli mitään tietoa ei tarvitse välttämättä tuplata (jos tuplaus helpottaa hetkellisesti niin sen ei tarvitse välttämättä näkyä taulussa jne.)
Tärkein pointti on kuitenkin, että tutkit mitä tapahtuu ja selvität miksi...
VBE:n helppiä kannattaa tutkia ja jos asia ei aukea helpin tiedoilla niin kannattaa metsästää tietoa Netistä käyttämällä helpissä esiintyviä termejä hakusanoina - taatusti löytyy hyviä esimerkkejä joka lähtöön...

-Nea

butterfly [13.12.2007 18:00:29]

Kiitosta taas Nea!

Pitkällisen pohdinnan jälkeen sain aikaiseksi toimivan jutun, joka vielä osaa hakea sarakkeesta A sijoituksen. En kylläkään saanut toimimaan sitä että tyhjät sarakkeet saisi pois. Yritin tuota sinun kirjoittamaa koodikin, mutta se ilmoitti jonkun virheen tuossa lopussa .Range(sarakkeet).Select kohdalla. Täytyy siis pohtia lisää.

butterfly [19.12.2007 10:00:50]

Hei. Tämä voi taas olla hieman yksinkertainen kysymys, mutta palatakseni ylläolevaan ongelmaani niin, kuinka voisin saada Taulukosta 2 haluamani arvot haluamaani kohtaan. Nyt saan se vaan menemään oikealle riville taulukkoon1, mutta samaan kohtaan, siis sarkkeeseen, kun ne ovat taulukossa 2. Siis jos arvo on ollut taulukossa 2 sarakkeessa D niin se menee sarakkeeseen D taulukossa 1:kin, vaikka haluaisin sen esimerkiksi sarakkeeseen C. Onkohan tähän joku kikka tai siis voiko sen jotenkin määritellä, kun näin aloittelijana en löydä ratkaisua.

groovyb [20.12.2007 23:02:37]

Dim taulukko(3, 1)
Dim i As Integer
Dim sisältö As String


        For i = 1 To 3
            Select Case i
                Case 1
                    sisältö = "moro "
                Case 2
                    sisältö = "Vaan "
                Case 3
                    sisältö = "kaikille"
            End Select
            taulukko(i, 0) = sisältö
        Next

        For i = 1 To 3
            Select Case i
                Case 1
                    sisältö = "ja "
                Case 2
                    sisältö = "hyvää "
                Case 3
                    sisältö = "joulua "
            End Select
            taulukko(i, 1) = sisältö
        Next
        TextBox1.Text = taulukko(2, 1) & taulukko(3, 1) & taulukko(1, 1) & taulukko(1, 0) & taulukko(3, 0)

'jos vaihdat vaikka tyyliin taulukko(1,1) = taulukko(3,0) niin teksti muuttuu siten et, että "ja " muuttuu sanaksi "kaikille " taulukon kohdassa taulukko(1,1)
'eli tuo taulukko(3,0) kopioituu taulukon kohtaan taulukko(1,1)

End Sub

butterfly [21.12.2007 10:16:39]

Hei taas. Entäs jos kun taulukot voivat paisua aika suuriksikin, eikö silloin ole aikas työlästä kirjoittaa tuollaista vai ymmärsinkö koodin oikein? Voi olla etten nyt ihan ymmärtänyt.

groovyb [21.12.2007 10:30:42]

tuossa nyt oli vain esimerkki miten voidaan kopioida taulukon kohdasta x taulukon kohtaan x. noissa for nexteissä vaan loin sisältöä niihin, ei se ollut oleellista.
tuo alin kommentti oli se tärkein pointti.

jos haluat että taulukon kohta taulukko(6) sisältämä data löytyykin kohdasta taulukko(5) niin sitten kopioit sen sinne.

taulukko(5) = taulukko(6)

muista vaan tallettaa tuon (5):sen sisältämä data jonnekkin muualle sitä ennen jos tarvitset sitä.

eli jos haluat taulukko(6,2) (6 = rivi ja 2 on sarake. riviltä 6 sarake 2) siirtää datan taulukkoon taulukko(3,5) niin se on vain

taulukko(3,5) = taulukko(6,2)

yleensä ottaen kun kerran alusta asti teet softan, niin järjestele datan vienti taulukkoon siten ettei jälkikäteen ole tarpeen vaihdella paikkoja taulukossa.

ja lukea kerran voi missä järjestyksessä tahansa.

textbox1.text = taulukko(3,1) & " " & taulukko(5,2) & " " & Taulukko(4,3)

neau33 [21.12.2007 12:21:51]

Heippa taas butterfly!

tässä olisi taas pikku viritelmä...

Testitaulut - testaa ensin, muuttele vasta sitten...

Taul1:

1. jutska
2. jutska
3. jutska
4. jutska
5. jutska
6. jutska
7. jutska
8. jutska
9. jutska
10. jutska

Taul2:

OTSIKOT         Maija   Matti   Lasse   Liisa   Vieno   Viljo
1. jutska       11      21      31      41      51      61
2. jutska       12      22      32      42      52      62
3. jutska       13      23      33      43      53      63
4. jutska       14      24      34      44      54      64
5. jutska       15      25      35      45      55      65
6. jutska       16      26      36      46      56      66
7. jutska       17      27      37      47      57      67
8. jutska       18      28      38      48      58      68
9. jutska       19      29      39      49      59      69
10. jutska      20      30      40      50      60      70

Taul3:

OTSIKOT         Paavo   Päivi   Orvokki Ossi    Veikko  Viola
1. jutska       71      81      91      101     111     121
2. jutska       72      82      92      102     112     122
3. jutska       73      83      93      103     113     123
4. jutska       74      84      94      104     114     124
5. jutska       75      85      95      105     115     125
6. jutska       76      86      96      106     116     126
7. jutska       77      87      97      107     117     127
8. jutska       78      88      98      108     118     128
9. jutska       79      89      99      109     119     129
10. jutska      80      90      100     110     120     130

ThisWorkbook:

'[k]käyttö: tuplaklikkaa tulua & anna palaa...[/k]
Private Sub Workbook_SheetBeforeDoubleClick(ByVal _
Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If Not UserForm1.Visible Then UserForm1.Show
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Saved = True
End Sub

Private Sub Workbook_BeforeSave( _
ByVal SaveAsUI As Boolean, Cancel As Boolean)
  'If ActiveWorkbook.Name = "theJutska.xls" Then Cancel = True
  '[k]tämä pikku kikka toimii siten, että kun olet tyytyväinen koodisi
  'niin tallennat työkirjan esim. nimellä XtheJutska.xls -> poistat
  'nämä rivit lukuunottamatta ylintä, josta poistat vain hipsun
  'edestä, tallennat työkirjan uudestaan, suljet työkirjan & muutat
  'tiedoston nimeksi theJutska.xls eli poistat X:n...[/k]
End Sub

UserForm1:

'Generaaleihin
Dim solu, alue, indeksi As Integer

Private Sub UserForm_Initialize()
'formille: CoboBoxi, ListBoxi, Label & pari nappia
  Me.Caption = ""
  Me.Width = 151: Me.Height = 191
  Me.SpecialEffect = fmSpecialEffectRaised
  Me.StartUpPosition = 1
  ComboBox1.Width = 130: ComboBox1.Top = 8
  ComboBox1.Left = _
  (Me.Width - ListBox1.Width) / 2 - 3
  ListBox1.Width = 130: ListBox1.Height = 80
  ListBox1.Top = 35: ListBox1.Left = _
  (Me.Width - ListBox1.Width) / 2 - 3
  CommandButton1.Caption = ""
  CommandButton1.Width = 12
  CommandButton1.Height = 12
  CommandButton1.ForeColor = &H80000009
  CommandButton1.Left = ListBox1.Left
  CommandButton1.Top = Me.Height
  Label1.Caption = ""
  Label1.AutoSize = False
  Label1.Left = ListBox1.Left
  Label1.Height = CommandButton1.Height
  Label1.Top = ListBox1.Top + _
  ListBox1.Height - (CommandButton1.Height / 2)
  Label1.SpecialEffect = fmSpecialEffectBump
  CommandButton2.Caption = "OK"
  CommandButton2.Width = 50
  CommandButton2.Height = 18
  CommandButton2.Left = _
  (Me.Width - CommandButton2.Width) / 2 - 3
  CommandButton2.Top = Me.Height _
  - (CommandButton2.Height * 3.3)

End Sub

Private Sub UserForm_Activate()

  ComboBox1.Clear
  Dim taul As Worksheet
  If ActiveWorkbook.Worksheets.Count > 1 Then
    For Each taul In ActiveWorkbook.Worksheets
      With taul
        If .Index > 1 Then ComboBox1.AddItem .Name
      End With
    Next
    ComboBox1.ListIndex = 0
  End If

End Sub

Private Sub ComboBox1_Change()

 indeksi = Sheets(ComboBox1.Text).Index: jutskaInit
 If ListBox1.ListCount = 0 Then
   CommandButton2.Enabled = False
 Else: CommandButton2.Enabled = True
 End If

End Sub

Private Sub CommandButton1_Click()

  Select Case Label1.Caption
    Case " valitse kaikki"
      For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = True
      Next i
        Label1.Caption = " poista valinnat"
        Label1.Width = Len(Label1.Caption) * 3.75
        Exit Sub
    Case Else
       For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = False
      Next i
        Label1.Caption = " valitse kaikki"
        Label1.Width = Len(Label1.Caption) * 3.75
  End Select

End Sub

Private Sub CommandButton1_Enter()

  Label1.BorderStyle = fmBorderStyleSingle
  Label1.BackColor = &HFFC0C0

End Sub

Private Sub CommandButton1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

  Label1.BorderStyle = fmBorderStyleNone
  Label1.SpecialEffect = fmSpecialEffectBump
  Label1.BackColor = &H8000000F

End Sub

Private Sub Label1_Click()

  CommandButton1.SetFocus
  CommandButton1_Click

End Sub

Private Sub ListBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

  If KeyCode = 32 Then tsekkaaValinnat

End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

  tsekkaaValinnat

End Sub

Private Sub CommandButton2_Click()

  Application.ScreenUpdating = False
  haku
  poista_sarakkeet
  Me.Caption = "Tiendosiirto valmis"
  Application.ScreenUpdating = True

End Sub

Sub jutskaInit()
  Application.ScreenUpdating = False
  ListBox1.Clear
  Dim pText As Boolean
  If ActiveSheet.Index = 1 Then
    Me.Caption = "Tuo tiedot..."
  Else
    Me.Caption = "Siirrä tiedot..."
  End If
  CommandButton1.Visible = False
  Label1.Visible = False
  Application.ScreenUpdating = False
  Sheets(indeksi).Activate
  alue = "A1:" & _
  Replace(Cells.SpecialCells( _
  xlCellTypeLastCell).Address, "$", "")
  Dim splitti() As String
  splitti = Split(alue, ":")
  For i = 1 To Len(splitti(1))
    If IsNumeric(Mid(splitti(1), i, 1)) Then
       splitti(1) = Left(splitti(1), i - 1): Exit For
    End If
  Next i
  For Each solu In Range("B1:" & splitti(1) & "1")
    pText = True
    For i = 1 To Len(solu.Text)
      If IsNumeric(Mid(solu.Value, i, 1)) Or _
        solu.Text = "" Then
        pText = False: Exit For
      End If
    Next i
    If pText Then _
    If Not solu.Value = "" Then _
    ListBox1.AddItem solu.Value
  Next
  If ListBox1.ListCount > 0 Then
    ListBox1.ListStyle = fmListStyleOption
    ListBox1.MultiSelect = fmMultiSelectMulti
    For i = 2 To Sheets(indeksi).Cells. _
    SpecialCells(xlCellTypeLastCell).Column
      For j = 0 To ListBox1.ListCount - 1
        If Sheets(1).Cells(1, i).Value = _
         ListBox1.List(j) Then
             ListBox1.Selected(j) = True
        End If
      Next j
    Next i
    CommandButton1.Visible = True
    Label1.Visible = True
    tsekkaaValinnat
  End If
  Sheets(1).Activate
  Application.ScreenUpdating = True

End Sub

Sub haku()

  Dim valinta As Boolean
  Sheets(1).Activate
    Range("B1:" & Sheets(indeksi).Cells. _
    SpecialCells(xlCellTypeLastCell).Address).Select
    Selection.Clear
    For Each solu In Sheets(indeksi).Range(alue)
      If Cells(solu.Row, 1).Value = _
      Sheets(indeksi).Cells(solu.Row, 1).Value Then
      For i = 0 To ListBox1.ListCount - 1
        valinta = False
        If ListBox1.List(i) = Sheets(indeksi).Cells(1, solu.Column).Text _
        And ListBox1.Selected(i) Then
          valinta = True: Exit For
        End If
      Next i
        Select Case valinta
          Case False
          '[k]ei tapahtumaa...[/k]
          Case Else
            Cells(solu.Row, solu.Column).Value = solu.Value
        End Select
       End If
     Next

End Sub

Sub poista_sarakkeet()

  Dim sarake As String, solu, sarakkeet As String
  With Sheets(1)
    sarake = _
    Replace(Sheets(indeksi).Cells.SpecialCells(xlCellTypeLastCell).Address, "$", "")
    For i = 1 To Len(sarake)
      If IsNumeric(Mid(sarake, i, 1)) Then _
      sarake = Left(sarake, i - 1): Exit For
    Next i
    For Each solu In .Range("B1:" & sarake & "1")
      If IsEmpty(solu) Then
        Dim xsolu, xSarake() As String
        tyhjää = True
        xSarake = Split(solu.Address, "$")
        Range(xSarake(1) & "1:" & xSarake(1) & _
        CStr(Sheets(indeksi).Cells.SpecialCells(xlCellTypeLastCell).Row)) _
        .Select
        If IsEmpty(RangeSelection) Then
          sarakkeet = sarakkeet & xSarake(1) & ":" & xSarake(1) & ","
        End If
      End If
    Next
    If Len(sarakkeet) > 1 Then
      sarakkeet = Left(sarakkeet, Len(sarakkeet) - 1)
      .Range(sarakkeet).Select
      Selection.Delete
      Cells(1, 1).Activate
    End If
  End With
  Erase xSarake

End Sub

Sub tsekkaaValinnat()

  Dim laskuri As Integer
  For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
      laskuri = laskuri + 1
    End If
  Next
  If laskuri = ListBox1.ListCount Then
    Label1.Caption = " poista valinnat"
  Else: Label1.Caption = " valitse kaikki"
  End If
  Label1.Width = Len(Label1.Caption) * 3.75

End Sub

butterfly [27.12.2007 11:20:16]

Hei Nea ja vau, nyt on niin jännittävän näköinen juttu, että tämä vaatii hieman aikaa, että tällainen asiasta vähän ymmärtävä pääsee jyvälle. Kiitos taas kuitenkin avusta, yritän katsella ja ymmärtää ja sulatella tätä juttua.

Sivun alkuun

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Kirjautuminen

Haku

Tehtävät

Kilpailu