VBA: Sortiermakro

[stober]

Hallo zusammen,

habe mich heute mit einem vba-Problem gequält und schlussendlich entschieden, mich hier anzumelden und um Rat zu fragen. Bin leider unerfahren, was das Macro schreiben angeht, aber bin mir sicher, dass mein Problem für euch locker zu lösen sein wird.

Es geht um ein Macro, dass eine Tabelle mit ca. 1000 Items in Zeile 1 und den zugehörigen Werten in Zeile 2 in strukturierte Tabellen aufteilt. Die Originaltabelle ist maschinell erstellt und daher steht in der ersten Zeile alles hintereinander weg ohne Struktur. Innerhalb der Items gibt es Gruppen und diese sollen jeweils einer eigenen Tabelle zugeordnet werden.

Das Grundskript steht bereits und hat bisher gut funktioniert – hier mal die relevanten Ausschnitte:

Code:

Call getData(1, 4, "A")
Call getData(5, 110, "B")
Call getData(111, 130, "C")
Call getData(131, 150, "D")
Call getData(151, 170, "E“)
Call….usw.

Sub
getData(ByVal colStart As Long, ByVal colEnd As Long, ByVal tName As String)
wB.Sheets("Tabelle1").Range(Num2Col(colStart) & ":" & Num2Col(colEnd)).Copy
Sheets(tName).Activate
Sheets(tName).Cells.Clear
Sheets(tName).[A1].PasteSpecial Paste:=xlPasteValues
End Sub
Function Num2Col(sNum As Long)
Num2Col = Left(Cells(1, sNum).Address(0, 0), 1 - (sNum > 26) - (sNum > 702))
End Function

Die Einteilungen der einzelnen Tabellen (A, B,C …) hat sich jetzt allerdings verändert, daher muss das Skript geändert werden.
Mein Hauptproblem ist, dass bei den neuen Originaldaten nicht mehr bei allen Tabellen die Werte direkt aufeinander folgen. Beispielsweise würden zu Tabelle „A“ die Werte 1 bis 4 und 9 bis 15 gehören.

Wie passe ich den vorliegenden Code so an, dass auch nicht zusammenhängende Werte in die richtigen Tabellen sortiert werden?
Ich scheitere leider bei der Anpassung der Range.


Falls jemand sogar Zeit und Lust hätte kurz zu erklären, wie „Num2Col“ und die wb.Sheets Zeile hier funktionieren, wäre ich sehr dankbar und wäre dem selbstständigen Schreiben von Macros ein Stück näher :D

Vielen Dank!

Gruß,
stober

[schauan]

Hallöchen,

erst mal zur letzten Frage.
Num2Col stellt erst mal die Zelladresse der ersten Zelle der übergebenen Spaltennummer fest. Normalerweise wird die absolut mit $ ausgegeben. Durch den Zusatz (0,0) werden die entfernt.
Der Spaltenbuchstabe ist dann der linke Teil. Je nachdem, welche Zahl übergeben wird, wird dann zur Berechnung die Spaltennummer herangezogen und was addiert. Bei Spalte 5 ist sNum>26 = FALSCH = 0 und das nächste auch, entsprechend bleibt es bei Left(...,1)

[stober]

Vielen Dank für die Antwort! Das erweitert auf jeden Fall mein Verständnis des Codes. Bin leider noch nicht in der Lage das Problem anzugehen.

Ich gebe euch am besten einmal das komplette Makro, um es verständlicher zu machen:

Code:

Dim eA As Excel.Application
Dim wB As Excel.Workbook
 
Sub doWork()
  Dim fso As Object, dName As Object
  Dim ePfad As String
  Dim vPfad As String
  Dim aPfad As String
  Dim nName As String
 
  ' Alle Excel-Dateien aus Eingang verarbeiten
  ePfad = ActiveWorkbook.Path & "\Eingang\"
  aPfad = ActiveWorkbook.Path & "\Ausgang\"
  vPfad = ActiveWorkbook.Path & "\Verarbeitet\"
  Set fso = CreateObject("Scripting.FilesystemObject")
  For Each dName In fso.getfolder(ePfad).Files
    Select Case LCase(fso.getextensionname(dName))
      Case "xls", "xla", "xlsm", "xlsx"
      
      ' Externe Datei öffnen
      Set eA = CreateObject("Excel.Application")
      'eA.Visible = True
      Set wB = eA.Workbooks.Open(dName)
      
      ' Daten übertragen
      Call getData(1, 4, "A")
      Call getData(5, 110, "B")
      Call getData(111, 130, "C")
      Call getData(131, 150, "D")
      Call getData(151, 170, "E")
      Call getData(171, 192, "F")
      Call getData(193, 206, "G")
         und so weiter..
      
      ' Externe Datei schließen
      eA.DisplayAlerts = False
      wB.Close
      Set wB = Nothing
      eA.Quit
      Set eA = Nothing
      
      ' Daten abspeichern in Datei
      Sheets.Copy
      ActiveWorkbook.SaveAs (aPfad & Replace(fso.getfilename(dName), "input", ""))
      ActiveWorkbook.Close
      
      ' Externe Datei in anderen Ordner verschieben
      Name dName As vPfad & fso.getfilename(dName)
      
      
    End Select
  Next
 
End Sub

Sub getData(ByVal colStart As Long, ByVal colEnd As Long, ByVal tName As String)
      wB.Sheets("Tabelle1").Range(Num2Col(colStart) & ":" & Num2Col(colEnd)).Copy
      Sheets(tName).Activate
      Sheets(tName).Cells.Clear
      Sheets(tName).[A1].PasteSpecial Paste:=xlPasteValues
End Sub

Function Num2Col(sNum As Long)
   Num2Col = Left(Cells(1, sNum).Address(0, 0), 1 - (sNum > 26) - (sNum > 702))
End Function

Hier zwei Bilder, die die Funktion des Makros verdeutlichen sollen:
Originaldaten:
Externer Link entfernt

Nach Verarbeitung:
Externer Link entfernt


Das Makro hat bisher gut funktioniert. Geändert hat sich, dass in den neuen Originaldaten die Items einiger bestimmter Tabellen nicht mehr direkt aufeinanderfolgen in Reihe 1, sondern Sprünge dazwischen sind. Diese Sprünge müssen irgendwie in den Code eingebaut werden. Allerdings sind die klar definiert - d.h., dass bei jeder Datei, die verarbeitet wird, die notwendigen Items für jede Tabelle an immer der gleichen Stelle stehen.

Hoffe das macht das Problem verständlicher.

Liebe Grüße,
stober