title image


Smiley Das kann z. B. so aussehen...


Option Explicit



Sub Start()



Dim strName As String

Dim strVerzeichnis As String

Dim strDaten As String

Dim col As New Collection

Dim c As Variant



Application.ScreenUpdating = False



col.Add "_1_l.xls"

col.Add "_1_r.xls"

col.Add "_1_lr.xls"

col.Add "_2_l.xls"

col.Add "_2_r.xls"

col.Add "_2_lr.xls"



strVerzeichnis = "d:\xlstest\"

strName = InputBox("Gib bitte den Namen ein:") 'z. B. 38



ActiveWorkbook.SaveAs strVerzeichnis & strName & ".xls"



For Each c In col

Call Import(strVerzeichnis, strName, CStr(c))

Next c



Application.ScreenUpdating = True



End Sub



Sub Import(strVerzeichnis As String, strName As String, strZusatz As String)



If Dir(strVerzeichnis & strName & strZusatz) = "" Then

Exit Sub

End If



Workbooks.Open Filename:=strVerzeichnis & strName & strZusatz



If InStr(1, strZusatz, "lr") = 0 Then

Sheets("Daten").Copy Before:=Workbooks(strName & ".xls").Sheets(1)

Workbooks(strName & ".xls").Sheets("Daten").Name = strName & Left(strZusatz, Len(strZusatz) - 4)

Else

Workbooks(strName & strZusatz).Sheets("Daten").Copy Before:=Workbooks(strName & ".xls").Sheets(1)

Workbooks(strName & ".xls").Sheets("Daten").Name = strName & Replace(Left(strZusatz, Len(strZusatz) - 4), "r", "")

Workbooks(strName & strZusatz).Sheets("Daten").Copy Before:=Workbooks(strName & ".xls").Sheets(1)

Workbooks(strName & ".xls").Sheets("Daten").Name = strName & Replace(Left(strZusatz, Len(strZusatz) - 4), "l", "")

End If



Workbooks(strName & strZusatz).Close savechanges:=False



End Sub





Ein X-Post ist ein Crossposting... ;o)

Gruß aus Ostfriesland. Möge Tux mit Dir sein!

ff


Proggst du schon .net oder quälst du dich noch mit VB6?



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: