Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1076to1080
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro um IF * erweitern

Makro um IF * erweitern
27.05.2009 22:15:36
Justine
hey zusammen,
ich hab mir ein makro gebastelt, welches mir aus ein tabellenblatt die infos auf ein deckblatt zieht die ich brauche. nur brauche ich jetzt eine möglichkeit das mein makro bei der eingabe von einen * automatisch das makro auf allen tabellenblätter laufen lässt.
kann mir dabei jemand helfen.
hier mein makro

Sub Versuch1()
Dim TabelleNr As String
' Kopie und Einfügen der Daten in das Deckblatt
'Application.DisplayAlerts = False
Application.ScreenUpdating = False
TabelleNr = InputBox("Bitte wählen Sie ein Tabellenblatt aus:")
On Error GoTo Fehler:
Sheets(TabelleNr).Select
Range("az1").Select
ActiveCell = ActiveSheet.Name
Selection.Copy
Sheets("Deckblatt").Select
Range("A21").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(TabelleNr).Select
Range("B6").Select
Selection.Copy
Sheets("Deckblatt").Select
Range("C21").Select
ActiveSheet.Paste
Range("D21").Select
Sheets(TabelleNr).Select
Range("L6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Deckblatt").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("E21").Select
Sheets(TabelleNr).Select
Range("G6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Deckblatt").Select
Range("E21").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("G21").Select
Sheets(TabelleNr).Select
Range("G5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Deckblatt").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Range("A21").Select
'Application.CutCopyMode = False
'ActiveCell.FormulaR1C1 = "Eintrag Tab"
Range("A9:G21").Select
Selection.Sort Key1:=Range("A9"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.ScreenUpdating = True
Fehler:
End Sub


3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Kurze Frage dazu
27.05.2009 22:51:50
NoNet
Hallo Justine,
ich habe Dein Makro etwas zusammengefasst und habe noch eine Frage zu Deiner Aufgabenstellung :
Wenn als Tabellenname ein Sternchen (*) eingegeben wurde, sollen die Daten aus ALLEN Tabellenblättern der Mappe in das "Deckblatt" übertragen werden. Sind das dann immer die gleichen Zellen (B6,L6, G6,G5) und immer in das Deckblatt in die Zeilen 21, 22, 23...etc. ?!?!?
Hier zunächst das zusammengefasste Makro - OHNE Lösung Deiner Anfrage :

Sub Versuch2()
Dim strTabelle As String
Dim wsDeckblatt As Worksheet, wsQuelle As Worksheet
' Kopie und Einfügen der Daten in das Deckblatt
Application.ScreenUpdating = False
strTabelle = InputBox("Bitte wählen Sie ein Tabellenblatt aus:")
If strTabelle  "" Then
Set wsDeckblatt = Sheets("Deckblatt")
Set wsQuelle = Sheets(strTabelle)
On Error GoTo Fehler
wsQuelle.Range("az1") = strTabelle
wsDeckblatt.Range("A21") = strTabelle
With wsDeckblatt
.[C21].Value = wsQuelle.[B6]
.[D21].Value = wsQuelle.[L6]
.[E21].Value = wsQuelle.[G6]
.[G21].Value = wsQuelle.[G5]
.[A9:G21].Sort Key1:=Range("A9"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End If
Fehler:
Application.ScreenUpdating = True
End Sub


Gruß, NoNet

Anzeige
AW: Makro um IF * erweitern
27.05.2009 23:02:35
Josef
Hallo Justine,
deine Angaben sind ein bisschen mager, aber probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Versuch1()
  Dim TabelleNr As String
  Dim objWS() As Worksheet, objWSDB As Worksheet
  Dim lngIndex As Long, lngRow As Long
  
  Set objWSDB = ThisWorkbook.Sheets("Deckblatt")
  
  TabelleNr = InputBox("Bitte wählen Sie ein Tabellenblatt aus:")
  
  If TabelleNr <> "*" Then
    If SheetExist(TabelleNr) Then
      Redim objWS(0)
      Set objWS(0) = Sheets(TabelleNr)
    Else
      MsgBox "Tabelle micht vorhanden!", vbExclamation, "Hinweis"
      Exit Sub
    End If
  Else
    Redim objWS(ThisWorkbook.Worksheets.Count - 2)
    For lngIndex = 0 To ThisWorkbook.Worksheets.Count - 1
      If Not ThisWorkbook.Worksheets(lngIndex + 1) Is objWSDB Then
        Set objWS(lngIndex) = ThisWorkbook.Worksheets(lngIndex + 1)
      End If
    Next
  End If
  
  lngRow = Application.Max(9, objWSDB.Cells(Rows.Count, 1).End(xlUp).Row + 1)
  
  If Not objWS(0) Is Nothing Then
    For lngIndex = 0 To UBound(objWS)
      With objWS(lngIndex)
        .Range("AZ1") = objWS(lngIndex).Name
        objWSDB.Cells(lngRow, 1) = .Range("AZ1").Value
        objWSDB.Cells(lngRow, 3) = .Range("B6").Value
        objWSDB.Cells(lngRow, 4) = .Range("L6").Value
        objWSDB.Cells(lngRow, 5) = .Range("G6").Value
        objWSDB.Cells(lngRow, 7) = .Range("G5").Value
        lngRow = lngRow + 1
      End With
    Next
    
    objWSDB.Range("A9:G" & CStr(lngRow - 1)).Sort _
      Key1:=objWSDB.Range("A9"), _
      Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom
  End If
  
  Set objWSDB = Nothing
End Sub

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

Gruß Sepp

Anzeige
ein kleiner Fehler - Korrektur.
27.05.2009 23:21:07
Josef
Hallo nochmal,
nimm diesen Code.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Versuch1()
  Dim TabelleNr As String
  Dim objWS() As Worksheet, objWSDB As Worksheet
  Dim lngIndex As Long, lngRow As Long
  
  Set objWSDB = ThisWorkbook.Sheets("Deckblatt")
  
  TabelleNr = InputBox("Bitte wählen Sie ein Tabellenblatt aus:")
  
  If TabelleNr <> "*" Then
    If SheetExist(TabelleNr) Then
      Redim objWS(0)
      Set objWS(0) = Sheets(TabelleNr)
    Else
      MsgBox "Tabelle micht vorhanden!", vbExclamation, "Hinweis"
      Exit Sub
    End If
  Else
    Redim objWS(ThisWorkbook.Worksheets.Count - 1)
    For lngIndex = 0 To ThisWorkbook.Worksheets.Count - 1
      If Not ThisWorkbook.Worksheets(lngIndex + 1) Is objWSDB Then
        Set objWS(lngIndex) = ThisWorkbook.Worksheets(lngIndex + 1)
      End If
    Next
  End If
  
  lngRow = Application.Max(9, objWSDB.Cells(Rows.Count, 1).End(xlUp).Row + 1)
  
  If Not objWS(0) Is Nothing Then
    For lngIndex = 0 To UBound(objWS)
      If Not objWS(lngIndex) Is Nothing Then
        With objWS(lngIndex)
          .Range("AZ1") = objWS(lngIndex).Name
          objWSDB.Cells(lngRow, 1) = .Range("AZ1").Value
          objWSDB.Cells(lngRow, 3) = .Range("B6").Value
          objWSDB.Cells(lngRow, 4) = .Range("L6").Value
          objWSDB.Cells(lngRow, 5) = .Range("G6").Value
          objWSDB.Cells(lngRow, 7) = .Range("G5").Value
          lngRow = lngRow + 1
        End With
      End If
    Next
    
    objWSDB.Range("A9:G" & CStr(lngRow - 1)).Sort _
      Key1:=objWSDB.Range("A9"), _
      Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom
  End If
  
  Set objWSDB = Nothing
End Sub

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

Gruß Sepp

Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige