Tabellen zusammenfügen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Tabellen zusammenfügen
von: Bianca
Geschrieben am: 09.09.2015 15:26:47

Hallo Leute,
bitte um Hilfe!
folgendes Problem:
2 Tabellen (Übersicht und Detail)
im ersten Sheet steht eine Übersicht aller Antragsnummern (1000-xxxx)
im zweiten Sheet stehen alle Bestellungen zu diesen Antragsnummern.
Ich möchte beide zusammenspielen und zwar so, dass unter der Zeile mit Auftragsnummer 1000 alle Bestellungen von 1000 eingefügt werden.
Am besten per Makro, da die Bestelldatei jede Woche länger wird.
Bitte, Bitte um Hilfe!!
Danke Bianca
Bsp. ist anbei
https://www.herber.de/bbs/user/100101.xlsx

Bild

Betrifft: AW: Tabellen zusammenfügen
von: Sepp
Geschrieben am: 09.09.2015 20:17:40
Hallo Bianca,
mal zum testen.
https://www.herber.de/bbs/user/100106.xlsm

Gruß Sepp


Bild

Betrifft: AW: Tabellen zusammenfügen
von: Bianca
Geschrieben am: 15.09.2015 10:31:30
Hallo Sepp,
ich hoffe du siehst das noch, denn eine Frage hätte ich noch:
Wie muss ich den Code umschreiben, wenn die Auftragsnummer nicht in Spalte D steht, sondern beispielsweise in Spalte Z und alles bis dahin kopiert werden soll?
Ich hab es selber versucht und komme leider nicht dahinter!
lg Bianca

Bild

Betrifft: AW: Tabellen zusammenfügen
von: Sepp
Geschrieben am: 15.09.2015 19:35:07
Hallo Bianca,
ich habe in den Code ein paar Konstanten eingearbeitet, mit denen du die Spalten vorgeben kannst.

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

Option Explicit

Sub zusammenfassung()
Dim vntAuflauf As Variant, vntOut() As Variant
Dim objSh As Worksheet, vntRet As Variant, rng As Range
Dim lngI As Long, lngAnswer As Long, lngR As Long, lngC As Long, lngInsert As Long
Dim strFirst As String

Const cSheetName As String = "Zusammenfassung"
Const cLngSearchColumn As Long = 4 'Spalte in "Bestellungen" die durchsucht wird - Anpassen!
Const cLngCriteriaColumn As Long = 2 'Spalte in der die Nummern in "Auflauf" stehen - Anpassen!
Const cLngLastColumn As Long = 3 'Spalte bis zu der die Daten aus "Bestellungen" übertragen werden sollen - Anpassen!

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
  .DisplayAlerts = False
End With

If Not SheetExist(cSheetName) Then
  Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
  objSh.Name = cSheetName
Else
  lngAnswer = MsgBox("Ausgabe auf Tabelle '" & cSheetName & "'" & vbTab & "= [JA]" & vbLf & _
    "Ausgabe auf neuem Tabellenblatt" & vbTab & "= [NEIN]", vbQuestion + vbYesNo)
  If lngAnswer = 7 Then
    Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
    objSh.Name = cSheetName & Format(Now, "_ddmmyy_hhmmss")
  ElseIf lngAnswer = 6 Then
    Set objSh = Sheets(cSheetName)
    objSh.UsedRange.Clear
  Else
    Exit Sub
  End If
End If

With Sheets("Auflauf")
  vntAuflauf = .Range("A2:H" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
  .Rows(1).Copy objSh.Range("A1")
End With

lngInsert = 2

With Sheets("Bestellungen")
  For lngI = 1 To UBound(vntAuflauf, 1)
    lngR = 1
    strFirst = ""
    Set rng = Nothing
    vntRet = Application.CountIf(.Columns(cLngSearchColumn), vntAuflauf(lngI, cLngCriteriaColumn))
    Redim vntOut(1 To vntRet + 1, 1 To Application.Max(cLngLastColumn, UBound(vntAuflauf, 2)))
    For lngC = 1 To UBound(vntAuflauf, 2)
      vntOut(1, lngC) = vntAuflauf(lngI, lngC)
    Next
    If vntRet > 0 Then
      Set rng = .Columns(cLngSearchColumn).Find(What:=vntAuflauf(lngI, cLngCriteriaColumn), LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False, After:=.Cells(1, 4))
      If Not rng Is Nothing Then
        strFirst = rng.Address
        Do
          lngR = lngR + 1
          For lngC = 1 To cLngLastColumn
            vntOut(lngR, lngC) = .Cells(rng.Row, lngC).Value
          Next
          Set rng = .Columns(cLngSearchColumn).FindNext(rng)
        Loop While Not rng Is Nothing And rng.Address <> strFirst
      End If
    End If
    objSh.Cells(lngInsert, 1).Resize(UBound(vntOut, 1), UBound(vntOut, 2)) = vntOut
    objSh.Cells(lngInsert, 1).Resize(1, UBound(vntOut, 2)).Font.Bold = True
    lngInsert = lngInsert + UBound(vntOut, 1) + 1
  Next
End With

objSh.Columns.AutoFit
objSh.Activate

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'zusammenfassung'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - zusammenfassung"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
  .DisplayAlerts = True
  .StatusBar = False
End With

Set objSh = Nothing
Set rng = Nothing
End Sub


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


Gruß Sepp


Bild

Betrifft: AW: Tabellen zusammenfügen
von: Bianca
Geschrieben am: 16.09.2015 10:11:36
Vielen Dank für deine Hilfe!!
lg Bianca

Bild

Betrifft: AW: Tabellen zusammenfügen
von: Bianca
Geschrieben am: 15.09.2015 09:17:13
Vielen Dank Sepp!
Hast mich gerettet :)

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Tabellen zusammenfügen"