Keskustelu: Ohjelmointikysymykset: Useamman excel tiedoston avaaminen VBA :lla

'ThisWorkbook
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)

 Dim OleObj As OLEObject, valittuna As Integer
  'Tutkii "Taul" ComboBoxit
 For Each OleObj In Sheets("Taul1").OLEObjects
   With OleObj
     If .Name = "ComboBox1" Then
       If ListIndex > -1 Then
         valittuna = valittuna + 1
       End If
     ElseIf .Name = "ComboBox2" Then
       If ListIndex > -1 Then
        valittuna = valittuna + 1
       End If
     End If
   End With
 Next

 Dim viesti As String, laskuri As Integer
  If Sheets("Taul1").Cells(2, 2).Value = 0 Then
    viesti = viesti + "Taul1 solu B2 OK"  + vbCrLf
    laskuri = laskuri + 1
  End If
  If IsEmpty(Sheets("Taul1").Cells(2, 3)) Or _
    CLng(Sheets("Taul1").Cells(2, 3).Value) = 0 Then
    viesti = viesti + "Taul1 solun C2 arvo puuttuu" + vbCrLf
    laskuri = laskuri + 1
  End If
  If IsEmpty(Sheets("Taul2").Cells(3, 3)) Or _
  CLng(Sheets("Taul2").Cells(3, 3).Value) = 0 Then
    viesti = viesti + "Taul2 solun C3 arvo puuttuu" + vbCrL
  End If
  'jne.
  If valittuna = 2 And viesti <> "" And laskuri > 1 Then
    viesti = "Tiedot kohteista:" + vbCrLf + viesti: MsgBox viesti
  Else
    MsgBox "Lähes kaikki tarvittavat tiedot puutuvat"
  End If

End Sub

'Toisen työkirjan avaaminen VBA:lla
Private Sub Workbook_SheetBeforeDoubleClick( _
ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

  'Esim. jos työpöydällä on tiedosto 'testi.xls'ja tämän työkirjan
  'jotain taulua kaksoisklikataan niin tiedosto avataan Excelissä.
  If Dir(Environ("userprofile") & "\Työpöytä\testi.xls") <> "" Then
    Workbooks.Open (Environ("userprofile") & "\Työpöytä\testi.xls")
  End If

End Sub

Sub auto_open()

  'Aliohjelma suoritetaan automaattisesti
  'aina kun macron sisältävä työkirja avataan...
  Dim BaseWorkbook As String, BasePath As String
  BaseWorkbook = Application.ActiveWorkbook.Name
  BasePath = Environ("userprofile") & "\Omat tiedostot\"
  On Error GoTo ErrorHandler
  MkDir (BasePath & "Excel_Tiedostot")

  On Error GoTo ErrorHandler
  MkDir (BasePath & "Excel_Tiedostot_Tarkistetut")

  On Error GoTo ErrorHandler
  MkDir (BasePath & "Excel_Tiedostot_Puutteelliset")

  With Application.FileSearch
    .LookIn = BasePath & "Excel_Tiedostot"
    .FileType = msoFileTypeExcelWorkbooks
    .Execute
    If .FoundFiles.Count > 0 Then
      For i = 1 To .FoundFiles.Count
        Workbooks.Open (.FoundFiles(i))
      Next i
      Dim wk As Workbook, wkOk As Boolean, msg As String
      Dim src As String, dest As String, cnt As Integer

      For Each wk In Application.Workbooks
        If wk.Name <> BaseWorkbook Then
          wk.Activate: DoEvents
          Dim ws As Worksheet
          Dim valittuna As Integer
          For Each ws In wk.Worksheets
            Dim oleobj As OLEObject
            For Each oleobj In ws.OLEObjects
              If Left(oleobj.Name, 8) = "ComboBox" Then
                With oleobj
                  If .Object.ListIndex > -1 Then
                    valittuna = valittuna + 1
                  End If
                End With
              End If
            Next

            Dim viesti As String, laskuri As Integer
            If ws.Cells(2, 2).Value = 0 And _
            Not IsEmpty(ws.Cells(2, 2)) Then
              viesti = viesti + "solun B2 arvo OK"
            Else
              viesti = viesti + "solun B2 arvo virheellinen"
            End If
            If IsEmpty(ws.Cells(2, 3)) Or _
            CLng(Sheets("Taul1").Cells(2, 3).Value) = 0 Then
              viesti = viesti + ws.Name & _
              " solun C2 arvo puuttuu" + vbCrLf
              laskuri = laskuri + 1
            End If
            If IsEmpty(ws.Cells(3, 3)) Or _
            CLng(ws.Cells(3, 3).Value) = 0 Then
              viesti = viesti + ws.Name & _
              " solun C3 arvo puuttuu" + vbCrL
              laskuri = laskuri + 1
            End If
           'jne.

            wkOk = False
            If laskuri < 2 And ws.Cells(2, 2).Value = 0 _
            And Not IsEmpty(ws.Cells(2, 2)) Then
              viesti = "Työkirjan '" & wk.Name & "' tiedot taulun '" & _
              ws.Name & "' kohteista:" & vbCrLf & _
              viesti: MsgBox viesti: wkOk = True:
              cnt = valittuna: viesti = ""
            Else
              wkOk = False: cnt = valittuna: viesti = "": Exit For
            End If
          Next
          If wkOk And cnt = 2 Then
            src = BasePath & "Excel_Tiedostot\" & wk.Name
            dest = BasePath & "Excel_Tiedostot_Tarkistetut\" & wk.Name
            msg = "Työkirjan '" + wk.Name + "* tiedot OK..." & vbCrLf _
            & "siirretään hakemistoon: " & dest
          Else
           src = BasePath & "Excel_Tiedostot\" & wk.Name
           dest = BasePath & "Excel_Tiedostot_Puutteelliset\" & wk.Name
            msg = "Työkirjan '" + wk.Name + _
           "' tiedot ovat puutteelliset..." & vbCrLf & _
           "siirretään hakemistoon: " & dest
          End If
          FileSaveOperation msg, src, dest, wk
        End If
      Next
      Workbooks(BaseWorkbook).Activate
    End If
  End With

  Exit Sub

ErrorHandler:

  Err.Clear: On Error GoTo 0
  Resume Next

End Sub

Sub FileSaveOperation(msg As String, src As String, _
ByVal dest As String, ByVal wk As Workbook)

  MsgBox msg
  Application.DisplayAlerts = False
  wk.Saved = True: wk.Close
  Application.DisplayAlerts = True
  FileCopy src, dest
  Do While (Dir(dest) = ""): Loop
  Kill (src)

End Sub