AW: Typen unverträglich
21.09.2004 13:44:27
Nicole
Hallo zusammen!
Hier wär also mein Code.....
Dim Mein_Export As String
Dim Mein_Export1 As String
Dim Meine_Datei As String
Dim Mein_Pfad As String
Dim Mein_Blatt As String
Dim max As Integer
Dim Antwort As String
Dim i As Integer
Sub ESAComp()
'Dateiname_ausgeben()
Meine_Datei = InputBox("Bitte geben sie den Dateinamen (ohne Endung) der zu verarbeitenden Excel Datei an. Sie muss bereits geöffnet sein.", "Dateieingabe")
Meine_Datei = Meine_Datei & ".xls"
'Tabellenblaetter_zählen()
Windows(Meine_Datei).Activate
max = Worksheets.Count
'Makroname_ausgeben()
Mein_Export = InputBox("Name der Textdatei (ohne Endung) .", "Dateieingabe")
Mein_Export1 = Mein_Export & ".xls"
'Excel Datei mit dem Namen Mein_Export und einem Sheet erstellen
Workbooks.Add
Mein_Pfad = ThisWorkbook.Path
ActiveWorkbook.SaveAs Filename:=Mein_Pfad & "\" & Mein_Export1
ActiveWorkbook.Save
For i = 2 To max
'Quell Tabellenblatt auswählen()
Windows(Meine_Datei).Activate
Mein_Blatt = Worksheets(i).Name
Worksheets(i).Activate
Range("A1").Select
phys = ActiveCell.Value
Select Case phys
Case Is = "REINFORCED PLY"
Call Riinforsd_pläi
Case Is = "HOMOGENEOUS PLY"
Call Homogeneous_Ply
Case Is = "ADHESIVE"
Call Adhesive
Case Is = "CORE PLY, HONEYCOMB"
Call CorePlyhoneycomb
Case Is = "CORE PLY, HOMOGENEOUS"
Call CorePlyHomogeneous
End Select
Next i
Windows(Mein_Export1).Activate
Call Leerzeilen_loeschen
'Call gaga
Call Abstandszeile_einfügen
Call Sterne_einfügen
Call Applicability
Call Spalten_verschieben
Call Textfile
'Call Schliessen_xls
Call Loeschen_xls
Windows("Makro_ESAComp_Datenbank.xls").Activate
End Sub
Sub Leerzeilen_loeschen()
Dim j As Double
Application.ScreenUpdating = False
For j = (i - 1) * 140 + 120 To 2 Step -1
If Cells(j, 1).Value = "" Or Cells(j, 2).Value = "" Then _
Cells(j, 1).EntireRow.Delete
Next j
Application.ScreenUpdating = True
End Sub
Sub Abstandszeile_einfügen()
Dim k As Integer
For k = 1 To Range("A65536").End(xlUp).Row
If Range("A" & k).Value = "Other data = " Or Range("A" & k).Value = "name = " Then
Rows(k + 1).Insert
Range(Cells(k + 1, 1).Address).Select
ActiveCell.FormulaR1C1 = "#---------------------------------------------------------------------------------"
End If
Next k
Range("A1").Select
ActiveCell.FormulaR1C1 = "#---------------------------------------------------------------------------------"
End Sub
Sub Sterne_einfügen()
Dim l As Integer
Dim l2 As Integer
For l = 1 To Range("A65536").End(xlUp).Row
If Range("A" & l).Value = "Manufacturer = " Then
For l2 = l To Range("A65536").End(xlUp).Row
Range("A" & l2).Value = "#" & Range("A" & l2).Value
If Range("A" & l2).Value = "#Other data = " Then Exit For
Next l2
End If
Next l
End Sub
Sub Applicability()
Windows(Mein_Export1).Activate
Range("G80").Select
ActiveCell.FormulaR1C1 = "=RC[-6]:R[7]C[-6]&RC[-5]:R[7]C[-5]&RC[-4]:R[7]C[-4]&RC[-3]:R[7]C[-3]&RC[-2]:R[7]C[-2]&RC[-1]:R[7]C[-1]"
Range("G80").Select
End Sub
Sub Spalten_verschieben()
Windows(Mein_Export1).Activate
Range("C1").Select
ActiveCell.FormulaR1C1 = "=RC[-2]:R[3]C[-2]&RC[-1]:R[3]C[-1]"
Range("C1").Select
Selection.AutoFill Destination:=Range("C1:C1000"), Type:=xlFillDefault
Range("C1:C1000").Select
Selection.Copy
Range("D1:D1000").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("D1:D1000").Select
Application.CutCopyMode = False
Selection.Copy
Range("A1:A1000").Select
ActiveSheet.Paste
Range("B1:D1000").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
End Sub
Sub Textfile()
Windows(Mein_Export1).Activate
Mein_Export = Mein_Export & ".txt"
ChDir Mein_Pfad
ActiveWorkbook.SaveAs Filename:= _
Mein_Pfad & "\" & Mein_Export, FileFormat:=xlTextPrinter, _
CreateBackup:=False
Windows("Makro_ESAComp_Datenbank.xls").Activate
Range("A13").Select
ActiveCell.FormulaR1C1 = "Bitte öffnen sie die zu verarbeitende Datei! "
Range("A24").Select
ActiveCell.FormulaR1C1 = "Die Textdatei befindet sich in: "
Range("A26").Select
ActiveCell.FormulaR1C1 = Mein_Pfad & "\" & Mein_Export
ActiveWindow.WindowState = xlNormal
ActiveWindow.WindowState = xlNormal
Range("A26").Select
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
Range("A13").Select
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
End Sub