Excel Tabellen und VB

Option Explicit
'Beschreibung der Quelldatei
Const c_QUELLDATEINAME As String = artikelinfo.xls
Const c_QUELLBLATTNAME As String = Tabelle1
Const c_QUELLE_SP_Nr As Long = 1   'entspricht Spalte A
Const c_QUELLE_SP_Text As Long = 3->entspricht Spalte C
Const c_QUELLE_Z_ERSTEWERTEZEILE = 1
'Beschreibung der Zieldatei
Const c_ZIELDATEINAME As String = preisliste.xls
Const c_ZIELBLATTNAME As String = Tabelle1
Const c_ZIEL_SP_Nr As Long = 1   ->entspricht Spalte A
Const c_ZIEL_SP_Text As Long = 12->entspricht Spalte L
Const c_ZIEL_Z_ERSTEWERTEZEILE = 1
'Formatierung
Const c_ZIEL_SP_Text_SPALTENBREITE = 255

'Trennzeichen der einzelnen Texte
Const c_TRENNZEICHEN =   
'**************************************************************
Sub ArtikelinfoTexteInPreislisteSpalteJAkkumulieren()
'****************************************************
'*** Erwartet werden geöffnete Quell- und Ziel-Dateien
'***
'*** Zu jeder Nummer im Ziel-Blatt werden die Zeilen im
'*** Quellblatt gesucht. Die Text-Spalte der gefundenen
'*** Zeile wird zu einem Text getrennt durch Trennzeichen
'*** zusammengefaßt und im Zielblatt in der Spalte der
'*** entsprechenden Nummer in die Text-Spalte geschrieben
'***
'*** Ist in der Quell-Datei keine entsprechende Nummer vorhanden
'*** wird diese nicht weiter behandelt.
'***
'*** in der Quelldaeti fehlerhafte Werte wie #NV, #Name, #Bezug,
'*** #Wert, usw. werden nicht mit übertragen. Am Ende erfolgt eine
'*** Report der fehlerhaften Zellen auf einem neu angelegten Blatt
'*** mit dem Namen FehlerhafteZellen_yyyymmddhhnn


  Dim wbq As Workbook, wsq As Worksheet, wbz As Workbook, wsz As Worksheet
  Dim b_Fehler As Boolean, f_err() As String, f_err_cnt As Long
  Dim s_Fehlerblatt As String
  
 ->Fehlerspeicher initialisieren
  f_err_cnt = 0: ReDim f_err(1 To 1)

 ->Quell-Blatt setzen
  If Not BlattSetzen(wbq, wsq, c_QUELLDATEINAME, c_QUELLBLATTNAME) Then
    GoTo Aufraeumen
  End If

 ->Ziel-Blatt setzen
  If Not BlattSetzen(wbz, wsz, c_ZIELDATEINAME, c_ZIELBLATTNAME) Then
    GoTo Aufraeumen
  End If

 ->Textspalte des Ziels formatieren
  wsz.Cells(1, c_ZIEL_SP_Text).EntireColumn.ColumnWidth = c_ZIEL_SP_Text_SPALTENBREITE
  wsz.Cells(1, c_ZIEL_SP_Text).EntireColumn.WrapText = True
  
 ->Texte zusammenfassen
  Call TexteZusammenfassen(wsq, wsz, f_err(), f_err_cnt)
  
 ->Fehlerauswertung
  If f_err_cnt = 0 Then
    MsgBox ( _
      Es sind keine fehlerhaften Zellen in  & _
      wbq.Name &  erkannt worden.)
  Else
    s_Fehlerblatt = Fehlerausgabe_Quelldatei(wbq, wsq, f_err(), f_err_cnt)
    MsgBox ( _
      Es sind  & f_err_cnt &  fehlerhaften Zellen in  & _
      wbq.Name &  erkannt worden. & vbLf & _
      Die betreffenden Zellen sind auf dem Blatt  & s_Fehlerblatt &  protokolliert.)
  End If

Aufraeumen:
  Set wbq = Nothing: Set wsq = Nothing: Set wbz = Nothing: Set wsz = Nothing
End Sub
'**************************************************************
Private Function Fehlerausgabe_Quelldatei(wbq As Workbook, wsq As Worksheet, _
                                          f_err() As String, f_err_cnt As Long) As String
 ->Fehlerausgabe der in der Quelldatei als fehlerhaft erkannten Zellen
  
  Dim ws As Worksheet, l_zeile As Long, l_spalte As Long, x As Long
  
 ->neues Blatt einfügen
  Set ws = wbq.Worksheets.Add(After:=wsq)
 -> Name FehlerhafteZellen_yyyymmddhhnn
  ws.Name = FehlerhafteZellen_ & Format(Now, yyyymmdd_hhnn)
  Fehlerausgabe_Quelldatei = ws.Name
  
  l_zeile = 1
  ws.Cells(l_zeile, 1).Value = _
    Protokoll der in  & wbq.Name &  als fehlerhaft erkannten Zellen.
  l_zeile = l_zeile + 2
  
  l_spalte = 0
  For x = 1 To f_err_cnt
    l_spalte = l_spalte + 1
    ws.Hyperlinks.Add _
      Anchor:=ws.Cells(l_zeile, l_spalte), _
      Address:=, _
      SubAddress:=wsq.Name & ! & f_err(x)
    ws.Cells(l_zeile, l_spalte).Value = f_err(x)
    If l_spalte = 10 Then
      l_spalte = 0: l_zeile = l_zeile + 1
    End If
  Next x
  
End Function
'**************************************************************
Private Function TexteZusammenfassen(wsq As Worksheet, wsz As Worksheet, _
                                    f_err() As String, f_err_cnt As Long)

  Dim l_qRows As Long, l_zRows As Long, s_zielNr As String
  Dim s_text As String, r As Range, z As Long, s_tmp As String
  Dim Zelle As Range, ersteAdresse As String
  
 ->Fehlerspeicher initialisieren
  f_err_cnt = 0
  ReDim f_err(1 To 1)
  
 ->Zeilenanzahl Quelle feststellen
  l_qRows = wsq.Cells(wsq.Rows.Count, c_QUELLE_SP_Nr).End(xlUp).Row
 ->Zeilenanzahl Ziel feststellen
  l_zRows = wsz.Cells(wsz.Rows.Count, c_ZIEL_SP_Nr).End(xlUp).Row
  
 ->Such-Range der Quelle definieren
  Set r = wsq.Range(wsq.Cells(c_QUELLE_Z_ERSTEWERTEZEILE, c_QUELLE_SP_Nr), _
                    wsq.Cells(l_qRows, c_QUELLE_SP_Nr))


 ->über alle Nummern der Zieldatei
  For z = c_ZIEL_Z_ERSTEWERTEZEILE To l_zRows
    s_zielNr = wsz.Cells(z, c_ZIEL_SP_Nr).Value
   ->leere übergehen
    If Trim(s_zielNr) <>  Then
     ->Text initialisieren
      s_text = 
     ->wsq.Activate
     ->ersten Eintrag Nummer auf dem Quell-Blatt suchen
      Set Zelle = r.Find(What:=s_zielNr, _
                        After:=wsq.Cells(l_qRows, c_QUELLE_SP_Nr), _
                        LookIn:=xlValues, _
                        Lookat:=xlWhole, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
      If Not Zelle Is Nothing Then
        ersteAdresse = Zelle.Address
        Do
         ->auf fehlerhaften Zellinhalt prüfen
         ->#NV, #Name, #Bezug, #Wert, usw.
          If IsError(wsq.Cells(Zelle.Row, c_QUELLE_SP_Text).Value) Then
           ->Fehlerfeld für Fehlereintrag um 1 vergrößern
            f_err_cnt = f_err_cnt + 1
            ReDim Preserve f_err(1 To f_err_cnt)
           ->Adresse der fehlerhaften Zelle im Fehlerfeld speichern
            f_err(f_err_cnt) = _
              wsq.Cells(Zelle.Row, c_QUELLE_SP_Text).Address( _
                      RowAbsolute:=False, ColumnAbsolute:=False)
          Else
           ->Text zusammenfassen
            If s_text =  Then
              s_text = wsq.Cells(Zelle.Row, c_QUELLE_SP_Text).Value
            Else
            s_text = s_text & c_TRENNZEICHEN & _
                      wsq.Cells(Zelle.Row, c_QUELLE_SP_Text).Value
            End If
          End If
         ->nächste Zelle mit Nummer suchen
          Set Zelle = r.FindNext(Zelle)
        Loop While Not Zelle Is Nothing And Zelle.Address <> ersteAdresse
       ->Zusammenfassung in Ziel eintragen
        wsz.Cells(z, c_ZIEL_SP_Text).Value = s_text
      End If
    End If
  Next z
Aufraeumen:
  Set r = Nothing: Set Zelle = Nothing
End Function
'**************************************************************
Private Function BlattSetzen(wb As Workbook, _
                            ws As Worksheet, _
                            s_DateiName As String, _
                            s_BlattName As String) As Boolean

  BlattSetzen = False
  
  On Error Resume Next
  Set wb = Workbooks(s_DateiName)
  If Err.Number <> 0 Then
    MsgBox ( _
      Die Mappe  & s_DateiName &  ist nicht geöffnet. & vbLf & _
      Bitte öffnen Sie die Mappe und starten das Makro erneut.)
    Err.Clear: On Error GoTo 0: Exit Function
  End If
  Set ws = wb.Worksheets(s_BlattName)
  If Err.Number <> 0 Then
    MsgBox ( _
      Das Blatt  & s_BlattName &  in der Mappe  & s_DateiName & _
       kann nicht geöffnet werden. & vbLf & _
      Bitte korrigieren Sie die Mappe und starten das Makro erneut.)
    Err.Clear: On Error GoTo 0: Exit Function
  End If
  
  On Error GoTo 0
  BlattSetzen = True
End Function