Keskustelu: Ohjelmointikysymykset: VBA: Rivien kopiointi

Sub auto_open()

 Application.ScreenUpdating = False
 For Each Worksheet In Worksheets

   With Worksheet
     .Activate
     For Each Shape In .Shapes
       With Shape
         If Left(.Name, 8) = "ComboBox" Then
           ActiveSheet.OLEObjects(.Name) _
           .object.AddItem "Tehtävät"
           ActiveSheet.OLEObjects(.Name) _
           .object.AddItem "Kopiointi"
           ActiveSheet.OLEObjects(.Name) _
           .object.ListIndex = 0
           .Placement = xlMoveAndSize
         End If
       End With
      Next
    End With
  Next
  Sheets(1).Activate
  Application.ScreenUpdating = True

End Sub

Public Sub ComboBoxinTila()

  Application.ScreenUpdating = False

  Select Case ComboBoxinTeksti()

    Case "Kopiointi"
      Dim Alue As Range, Rivi As Long, _
      Sarake() As String, Tieto As Boolean

      Sarake = Split(Cells.SpecialCells( _
      xlCellTypeLastCell).address, "$")

      Rivi = ComboBoxinRivi()

      For i = 1 To Val(Sarake(2))
        If Not IsEmpty(Cells( _
        Rivi, i).Value) Then
          Tieto = True: Exit For
        End If
      Next i

      If Not Tieto Then
        MsgBox "Ei siirrettävää dataa", _
        vbInformation, Application.Caption
        Erase Sarake: Set ComboBoxi = Nothing
        Application.ScreenUpdating = True: Exit Sub
      End If

      Set Alue = Range("A" & CStr(Rivi) _
      & ":" & Sarake(1) & CStr(Rivi))

      Select Case Sheets("Taul6").Range( _
      "A" & Sheets("Taul6").Cells.SpecialCells( _
      xlCellTypeLastCell).Row).Value

       Case Empty
          Rivi = Sheets("Taul6").Cells. _
          SpecialCells(xlCellTypeLastCell).Row
       Case Else
         Rivi = Sheets("Taul6").Cells. _
        SpecialCells(xlCellTypeLastCell).Row + 1
     End Select

     Alue.Select: Selection.Copy _
     Destination:=Worksheets("Taul6"). _
     Range("A" & CStr(Rivi))
     Range("A1").Select: Set Alue = Nothing
     Sheets("Taul6").Activate
     Erase Sarake: Set ComboBoxi = Nothing

  End Select

  Application.ScreenUpdating = True

End Sub

Public Function ComboBoxinTeksti() As String

  Dim OleObjekti As OLEObject
  For Each OleObjekti In ActiveSheet.OLEObjects
    With OleObjekti
      If .object.Value = "Kopiointi" Then
        ComboBoxinTeksti = .object.Value
      End If
    End With
  Next

End Function

Public Function ComboBoxinRivi() As Long

  Dim OleObjekti As OLEObject
  For Each OleObjekti In ActiveSheet.OLEObjects
    With OleObjekti
      If .object.Value = "Kopiointi" Then
        Dim korkeus As Long
        For i = 1 To ActiveSheet.Rows.Count
          korkeus = _
          korkeus + ActiveSheet.Rows(i).RowHeight
          If .Top >= korkeus And .Top < ActiveSheet. _
            Rows(i + 1).RowHeight + korkeus Then
            .object.ListIndex = 0
            ComboBoxinRivi = i + 1: Exit Function
          End If
        Next i
      End If
    End With
  Next

End Function