Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

@Sepp: Zwei Bitten! | Herbers Excel-Forum


Betrifft: @Sepp: Zwei Bitten! von: Claudia
Geschrieben am: 09.01.2010 20:02:38

Hallo Sepp,

Du hattest mir netterweise folgenden VBA-Code geschrieben.

https://www.herber.de/forum/archiv/1116to1120/t1118104.htm#1118104

Hierzu habe ich zwei Bitten.

Ich hole mir auch Tabellen aus Dateien, die Verknüpfungen haben. Beim rüberkopieren werde ich so also immer gefragt und muss das aktualisieren manuell bejahen. Kannst Du diese Abfrage noch in den Code einbauen?

Zweite Bitte: Manche Dateien beinhalten die gleichen Tabellennamen, so dass beim rauskopieren diese Sheets dann in meiner Datei hochgezählt werden.

Werte
Werte(2)
Werte(3)

Es wäre prima, wenn hier folgende Lösung möglich ist. In meinem Reiter Übersicht trage ich ja in Spalte B ein, welche Tabelle rauskopiert werden soll. Wäre es möglich, wenn ich in der gleichen Zelle dahinter mit einem Bindestrich ggf. den neuen Namen eintragen kann, wie die rausgekopierte Tabelle in meiner Datei dann heissen soll.

Beispiel: Werte - danke
gesuchte Tabelle = Werte
soll dann in meiner Datei heissen =danke

Verständändlich? Wärst Du so nett?

Vielen lieben Dank im Voraus!

LG
Claudia

  

Betrifft: Sepp: Hier nun der Code: von: Claudia
Geschrieben am: 09.01.2010 20:10:13

Der betreffende Code - sehe ich gerade - ist aber folgender. Hatte ich im Forum aufgelesen. Den Code müsstest Du auch geschrieben haben. Glaube ich zumindest.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub importSheets()
Dim objSh As Worksheet, objDel As Worksheet, objWb As Workbook
Dim lngRow As Long, lngLast As Long


On Error GoTo ErrExit
GMS
Set objSh = Sheets("Übersicht")

With objSh
For Each objDel In .Parent.Worksheets
If Not objDel Is objSh Then objDel.Delete
Next

lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)

.Range("C2:C" & Rows.Count).ClearContents

For lngRow = 2 To lngLast
If .Cells(lngRow, 1) <> "" Then
If Dir(.Cells(lngRow, 1).Text, vbNormal) <> "" Then
Set objWb = Workbooks.Open(.Cells(lngRow, 1).Text)
If SheetExist(.Cells(lngRow, 2).Text, objWb) Then
objWb.Sheets(.Cells(lngRow, 2).Text).Copy After:=.Parent.Sheets(.Parent.Sheets.Count)
.Cells(lngRow, 3) = "Importiert"
Else
.Cells(lngRow, 3) = "Tabelle nicht vorhanden"
End If
objWb.Close False
Else
.Cells(lngRow, 3) = "Datei nicht vorhanden"
End If
End If
Next
.Activate
End With



ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (importSheets) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / importSheets"
End With

GMS True

Set objWb = Nothing
Set objSh = Nothing
Set objDel = Nothing
End Sub

Public Sub GMS(Optional ByVal Modus As Boolean = False)
  
  Static lngCalc As Long
  
  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
    
  End With
  
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If wks.Name = sheetName Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function



  

Betrifft: AW: Sepp: Hier nun der Code: von: Josef Ehrensberger
Geschrieben am: 09.01.2010 20:24:33

Hallo Claudia,

ungetestet.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub importSheets()
  Dim objSh As Worksheet, objDel As Worksheet, objWb As Workbook
  Dim lngRow As Long, lngLast As Long, vntName As Variant
  
  
  On Error GoTo ErrExit
  GMS
  Set objSh = Sheets("Übersicht")
  
  With objSh
    For Each objDel In .Parent.Worksheets
      If Not objDel Is objSh Then objDel.Delete
    Next
    
    lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
    
    .Range("C2:C" & Rows.Count).ClearContents
    
    For lngRow = 2 To lngLast
      If .Cells(lngRow, 1) <> "" Then
        If Dir(.Cells(lngRow, 1).Text, vbNormal) <> "" Then
          If InStr(1, .Cells(lngRow, 2).Text, "-") > 0 Then
            vntName = Split(.Cells(lngRow, 2), "-")
          Else
            vntName = Array(.Cells(lngRow, 2).Text, .Cells(lngRow, 2).Text)
          End If
          Set objWb = Workbooks.Open(.Cells(lngRow, 1).Text, UpdateLinks:=True)
          If SheetExist(Trim(vntName(0)), objWb) Then
            objWb.Sheets(Trim(vntName(0))).Copy After:=.Parent.Sheets(.Parent.Sheets.Count)
            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Trim(vntName(1))
            .Cells(lngRow, 3) = "Importiert"
          Else
            .Cells(lngRow, 3) = "Tabelle nicht vorhanden"
          End If
          objWb.Close False
        Else
          .Cells(lngRow, 3) = "Datei nicht vorhanden"
        End If
      End If
      Erase vntName
    Next
    .Activate
  End With
  
  
  
  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (importSheets) in Modul Modul1", _
      vbExclamation, "Fehler in Modul1 / importSheets"
  End With
  
  GMS True
  
  Set objWb = Nothing
  Set objSh = Nothing
  Set objDel = Nothing
End Sub

Public Sub GMS(Optional ByVal Modus As Boolean = False)
  
  Static lngCalc As Long
  
  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
    
  End With
  
End Sub


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If wks.Name = sheetName Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function



Gruß Sepp



  

Betrifft: AW: @Sepp: Zwei Bitten! von: Josef Ehrensberger
Geschrieben am: 09.01.2010 20:16:39

Hallo Claudia,

ich helfe dir gerne, aber in dem von dir angeführten Thread, werden keine Tabellen aus
anderen Dateien importiert. Poste den Code, oder noch besser, lade eine Datei mit dem Code
und den neuen Tabellennamen hoch.


Gruß Sepp



  

Betrifft: Vielen vielen Dank und noch ein schönes WE von: Claudia
Geschrieben am: 09.01.2010 22:11:20