Daten aus einer Spalte auslesen und in einer File

Sub speichern()
' test Macro
' Macro recorded 12.05.2003 by Rene Möller
Dim RESI_Satz As String             'RESI Programierdatensatz
Dim RESI_Karten_Nr As String        'RESI Kartennummer (für Dateinamenerstellung/Blattnahme/ _
evtl. auch mal als Kommunikationseinstelluing bei Direktbeschreibung
Dim RESI_Komplett As String         'Komplette RESI Nummer (z.B.:RESI 1201-0319)
Dim Aktueller_Pfad As String        'Pfad in dem dieses File steht, default für RESI-Datei
Dim Directory As String             'Pfad in den die RESI Datei geschrieben werden soll
Dim Name_File As String             'Filename für RESI-Datei
Dim Speicherung As String           'Variable für RESI-Datei (Pfad & Dateiname)
Dim Setup_File_Direktory As String  'Tabellenname der Setup-Infos
Dim Altes_aktives_Blatt As String   'Tabellenblattname von dem Makro aufgerufen
Dim Aktives_Blatt_neu As String     'Tabellenblattname mit allen Infos update
Dim Datum_kurz As String            'Hilfsstring für Dateinamenerstellung
Dim Name_File_Hilfe As String       'Filename für RESI-Datei
Dim Prueflinie As String            'enthält Prüfliniennummer für Dateinamenerstellung
Dim Pruefkopf As String             'enthält Prüfkopf für Dateinamenerstellung
Dim i As Integer                    'allg. Zählervariable
Dim Fehler_RESI_Satz As Integer     'Fehler beim Zusammenstellen der RESI-Daten (leere  _
Zellen)
Fehler_RESI_Satz = 0                'kein Fehler
RESI_Satz = ""                      'RESI-Datensatz definiert leeren
Aktueller_Pfad = Application.ActiveWorkbook.Path 'aktueller Pfad dieser Datei auslesen
Setup_File_Direktory = "Setup_File_Direktory"
Altes_aktives_Blatt = ActiveSheet.Name
Range("B17").Select
RESI_Karten_Nr = ActiveCell.Value               'aktuelle RESI Kartennummer auslesen
Pruefkopf = ActiveCell.Offset(1, 0).Value       'aktuelle Prüfkopfnummer auslesen
If RESI_Karten_Nr = "" Or Pruefkopf = "" Then   'Mußfelder RESI-Kartennummer und Prüfkopf  _
checken
MsgBox ("RESI- Karten und Prüfkopfnummer überprüfen! " & Chr$(13) _
& "Informationen sind zwingend nötig!")
Exit Sub
End If
Pruefkopf = "#" & Pruefkopf                     'aktuelle Prüfkopfnummer komplettieren
RESI_Komplett = "RESI_1201-" & RESI_Karten_Nr   'Komplette RESI Nummer erstellen
Sheets(Setup_File_Direktory).Select         'Setup Blatt aufrufen
Range("B3").Select
ActiveCell.Value = Aktueller_Pfad           'Default Pfad im Setup_Blatt auf aktuellen  _
dieser Datei setzen
Directory = ActiveCell.Offset(-1, 0).Value  'Wunschzielverzeichnis auslesen
Datum_kurz = ActiveCell.Offset(-2, 0).Value 'Hilfsstring für Dateinamenerstellung auslesen
Prueflinie = ActiveCell.Offset(1, 0).Value  'Prüfliniennummer für Dateinamenerstellung  _
auslesen
Sheets(Altes_aktives_Blatt).Select          'aufs Blatt zurück, von dem Macro gestartet
'Start der Schleife um RESI-Daten zusammen zu kopieren:
For i = 7 To 16
Range("G" & i).Select
If ActiveCell.Value = "" Then                    'Falls kein (leerer)Daensatz -> Fehler  _
setzen
Fehler_RESI_Satz = Fehler_RESI_Satz + 1
End If
RESI_Satz = RESI_Satz & ActiveCell.Value & Chr(9)   'Daten in "RESI_Satz" Schreiben
Next i
'Ende der Schleife um Daten zusammen zu kopiern
If Fehler_RESI_Satz  0 Then                       ' Fehler RESI-Datensatz prüfen
MsgBox ("RESI- Datensatz nicht vollständig!" & Chr$(13) _
& "Alle Messungen durchführen und Werte eintragen!")
Exit Sub
End If
'Blattname neu definieren:
Aktives_Blatt_neu = Prueflinie & "_" & Pruefkopf & "_" & RESI_Komplett
Sheets(Altes_aktives_Blatt).Name = Aktives_Blatt_neu    'aktuelles Blatt umbenennen
'Variable altes aktives Blatt auf aktualisierten Blattname setzen:
Altes_aktives_Blatt = Aktives_Blatt_neu
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst   'Scrollbutton ganz nach links
'Filename aus Inzelinfo's zusammensetzen:
Name_File = RESI_Komplett & "_" & Prueflinie & "_" & Pruefkopf & "_" & Datum_kurz & ".xya"
Speicherung = Directory & "\" & Name_File       'Speichername mit Pfadinfo erstellen
On Error GoTo Fehler
Datei_oefnnen:
Open Speicherung For Output As #1
Print #1, RESI_Satz
Close #1
Range("B19").Select
ActiveCell.Value = Speicherung                'Speichername mit Pfadinfo im aktuellen Blatt  _
anzeigen
Exit Sub
Fehler:
Speicherung = Aktueller_Pfad & "\" & Name_File
MsgBox ("Angegebener Speicherpfad ist nicht gültig! " & Chr$(13) & "Datei wurde im  _
Verzeichnis:" & Chr$(13) & Aktueller_Pfad & Chr$(13) & "abgespeichert!")
GoTo Datei_oefnnen
End Sub