Keskustelu: Ohjelmointikysymykset: VBA: Mitenkä

Nappo [20.09.2010 14:08:05]

saan taul1:sestä valitulta määräämättömältä riviltä siirretyä haluttujen solujen tiedot taul2:selle haluamiini soluihin

Lue keskustelun ohjeet ja kirjoita selvempiä kysymyksiä! Terv. moderaattori.

Graphic [20.09.2010 15:22:07]

http://www.catb.org/esr/faqs/smart-questions.html#bespecific

Nappo [21.09.2010 13:38:04]

.  A      B      C       D
1  1500   1999   47994   0,14

Elikkä, jos Taul1:ssä on esim. tälläisiä arvoja millaisella ohjausobjektilla saan valittua ne tai muulla rivillä olevat arvot ja vietyä ne Taul2:ssa olevaan pohjaan (joka luvulle on määritelty solu minne niiden pitäisi sijoittua)

Mod. lisäsi kooditagit

neau33 [21.09.2010 14:31:13]

Moi Nappo!

Jos ymmärsin oikein niin kyseessä on Excel-työkirjan taulut, elikä aivan aluksi olisit voinut otsikoida aiheen vaikkapa tyyliin: Excel/VBA-kopiointi työkirjan taulusta toiseen...

'Yksinkertainen esimerkki:
'Oletus: Tauluun "Taul1 on" raahattu Komentopainike (CommandButton1)
Private Sub CommandButton1_Click()

    Dim i As integer

    For i = 1 To 4

        'Taulun "Taul2" Solun(rivi 1,
        'laskurin i osoittaman sarakkeen).Arvoksi asetetaan
        'Taulun "Taul1" Solun(rivi 1,
        'laskurin i osoittaman sarakkeen).Arvo

        Sheets("Taul2").Cells(1, i).Value = _
        Sheets("Taul1").Cells(1, i).Value

    Next i

End Sub

'Edellistä hieman mutkikkaampi esimerkki:
Private Sub CommandButton1_Click()

    Dim i As integer

    For i = 1 To Sheets("Taul1").Columns.Count

       Select Case i

          Case 2 'tapauksessa, että laskurin i arvo on 2 (esim.)

             'Taulun "Taul2" Solun(rivi 3,sarakkeen 5).Arvoksi asetetaan
             'Taulun "Taul1" Solun(rivi 3,
             'laskurin i osoittaman sarakkeen).Arvo

              Sheets("Taul2").Cells(3, 5).Value = _
              Sheets("Taul1").Cells(3, i).Value

           Case 7 'tapauksessa, että laskurin i arvo...
              'jne.
       End Select

    Next i

End Sub

neau33 [21.09.2010 18:43:23]

MOI Taas Nappo!

tässä vielä hieman edistyneempi esimerkki...

VBAProject:
Lisää työkirjan taulun Taul1 ensimmäiseen soluun komentopainike (CommandButton1) & aseta painikkeen Caption-arvoksi: VALITSE

Käyttö: kirjoita tauluun Taul1 riviltä 2 eteenpäin haluamiisi soluihin haluamiasi arvoja ja paina sen jälkeen kometopainiketta. Valise sitten hiirellä taulusta Taul1 yksitellen haluamiasi (arvon sisältäviä) soluja. Kun olet valinnut haluamasi solut aktivoi työkirjan taulu Taul2. Valitse sitten taulusta Taul2 riviltä 2 eteenpäin hiirellä yksitellen haluamiasi soluja. Kun olet valinnut Taul2:sta yhtä monta solua, kuin valitsit Taul1:stä niin Taul1:stä valitsemasi arvot kopioituvat Taul2:sta valitsemiisi soluihin valintajärjestyksen mukaisesti.

'Taul1
Private Sub CommandButton1_Click()

   Select Case CommandButton1.Caption
      Case "VALITSE"
         SelectMode = True
         CommandButton1.Caption = "POISTA"
         Exit Sub
      Case "POISTA"
         SelectMode = False
         Erase Taulu1Solut, Taulu2Solut
         CommandButton1.Caption = "VALITSE"
   End Select

End Sub

Private Sub Worksheet_Activate()
   Cells(1, 1).Select
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

   If Target.Row = 1 Or Not SelectMode Then
      Exit Sub
   End If

   SetAdresses ActiveSheet.index, Target.address

End Sub

'Taul2
Private Sub Worksheet_Activate()
   Cells(1, 1).Select
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

   If Target.Row = 1 Or Not SelectMode Then
      Exit Sub
   End If

   SetAdresses ActiveSheet.index, Target.address

End Sub

'Module1
Public Taulu1Solut(), Taulu2Solut()
Public SelectMode As Boolean

Public Sub SetAdresses(ByVal index As Integer, address As String)

   Select Case index

      Case 1

         If Sheets(1).Range(address).Text = "" Then

            MsgBox "Valittu  solu ei siällä arvoa!": Exit Sub

         End If

         On Error Resume Next

         Dim lb1: lb1 = LBound(Taulu1Solut)

         If Err <> 0 Then

            Err.Clear: On Error GoTo 0
            ReDim Taulu1Solut(0)

         Else

            For i = LBound(Taulu1Solut) To UBound(Taulu1Solut)

               If Taulu1Solut(i) = address Then
                  MsgBox "Solu on jo valittu!": Exit Sub
               End If

            Next i

            ReDim Preserve Taulu1Solut(UBound(Taulu1Solut) + 1)

         End If

         Taulu1Solut(UBound(Taulu1Solut)) = address

      Case 2

         On Error Resume Next
         Dim lbx: lbx = UBound(Taulu1Solut)

         If Err <> 0 Then

            Err.Clear: On Error GoTo 0
            MsgBox "Taulusta " + Chr(34) + _
            Sheets("Taul1").Name + Chr(34) + _
            " ei ole valittu yhtään arvon sisltävää solua!"

            Sheets(1).Activate: Exit Sub

         End If

         On Error Resume Next

         Dim lb2: lb2 = UBound(Taulu2Solut)

         If Err <> 0 Then

            Err.Clear: On Error GoTo 0
            ReDim Taulu2Solut(0)

         Else

            For i = 0 To UBound(Taulu2Solut)

               If Taulu2Solut(i) = address Then
                  MsgBox "Solu on jo valittu!": Exit Sub
               End If

            Next i

            ReDim Preserve Taulu2Solut(UBound(Taulu2Solut) + 1)

         End If

         Taulu2Solut(UBound(Taulu2Solut)) = address

         If UBound(Taulu2Solut) = UBound(Taulu1Solut) Then

            For i = LBound(Taulu1Solut) To UBound(Taulu1Solut)
               Sheets(2).Range(Taulu2Solut(i)).Value = _
               Sheets(1).Range(Taulu1Solut(i)).Value
            Next i

            Erase Taulu1Solut, Taulu2Solut
            Sheets(1).CommandButton1.Caption = "VALITSE"
            SelectMode = False: Exit Sub

         End If

   End Select

End Sub

Vastaus

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

Kirjautuminen

Haku