AW: Makro erst nach Datei öffnen ausführen
23.04.2005 19:18:20
Frank
Hallo Nepumuk,
es gibt eine gute und eine ... etwas weniger gute Nachricht. Die Gute Der Timer Funktioniert soweit, nur dass ich den genauen Namen der datei eingeben muß. Da die sich ändert wirds kompliziert. Zum anderen kommt die Message schon bevor ich die Datei im Filelidtfeld selektiert habe. Denke, das könnte man beheben. Jetzt kommt die Schlechte. Mein ganzer Code "Text_in_Spalten ist unter VBA geschrieben. VB kann den Code nicht lesen - in jeder zweiten Zeile Fehler, fehler....
Ich werde es so lassen wie bisher. Ich zeig Dir mal wie mein Code aussieht.
Schönen Abend noch Frank
Sub Text_in_Spalten()
Dim arrText, i As Integer, iCnt As Long
Application.ScreenUpdating = False
For iCnt = 1 To Range("A65536").End(xlUp).Row
arrText = Split(Cells(iCnt, 1), ";")
For i = 0 To UBound(arrText)
Cells(iCnt, i + 1) = arrText(i)
Next i
Next iCnt
Columns("D:G").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Application.CutCopyMode = False
kopieren
End Sub
Sub kopieren()
Sheets(1).Select
Sheets(1).Copy Before:=Workbooks("Kim_1.xls"). _
Sheets(1)
Application.Run "Kim_1.xls!transpons"
Sheets(1).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets(3).Select
End Sub
Sub transpons()
Dim intRow As Integer
Dim x As String
Range("A1:HQ100").Select
Selection.Copy
Sheets("Tabelle1").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Rows("2:2").Select ' Zeile 2 gelöscht
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A1").Select
Application.DisplayAlerts = False
Create_Sheets
End Sub
Sub Create_Sheets()
Dim i As Integer
Dim lngRow As Long
Dim qWks As Worksheet, tWks As Worksheet
Dim ziel
Set qWks = Worksheets("Tabelle1")
With qWks
For i = 2 To .Range("IV2").End(xlToLeft).Column ' auswahl betrifft Spalte B bis letzte IV
'If Len(.Cells(2, i)) > 0 And Len(.Cells(2, i)) < 9 Then 'sucht nach werten >8 zeichen
If .Cells(2, i) <> "" Then ' wenn in Zeile zwei in Spalte Wert gefunden dann
Set tWks = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'erstelle ein Arbeitsblatt nach ("Tabelle1")
tWks.Name = .Cells(2, i).Text ' und übernehme den namen für das arbeitsblatt aus dem Zellenwert
.Range(.Cells(3, i), .Cells(.Cells(65536, i).End(xlUp).Row, i)).Copy tWks.Cells(2, 3) 'gehe in die Spalte und kopiere ab Zeile 3 bis zum letzten gefundenen Datensatz (Range 3 - 65536(max Zeile) in Zeile 2 Spalte 3
ziel = tWks.Name 'im neuangelegten Arbeitsblatt
Sheets("Radius").Columns("A:B").Copy ' gehe ins Arbeitsblatt Radius - kopiere Spalte A und B
Sheets(ziel).Columns("A:B").Select ' gehe in das neuangelegte Datenblatt markiere Spalten a und
ActiveSheet.Paste 'und füge Spalten in A und B ein
.Cells(1, i).Copy tWks.Cells(1, 1) ' übernehme Wert aus B1,B2,B3,usw... und trage ein in generiertes Datenblatt A1
ziel = tWks.Name
Range("A1").Select
Selection.Font.ColorIndex = 3 ' ändere die schriftfarbe in Rot
Selection.Font.Bold = True ' und Fettgedruckt
ziel = tWks.Name
Columns("C:F").Select
'Selection.Replace What:=".", Replacement:=""
Selection.Replace What:=",", Replacement:="." ' Textzelle in Zahlzelle umgewandelt
'Cells(Rows.Count, Columns.Count).Copy
'Selection.PasteSpecial Paste:=-4104, Operation:=2
Cells.Select
Selection.Replace What:="N/A", Replacement:="0", ReplaceFormat:=False ' suche zellen nach N/A und erstelle eine leerzelle
Selection.Replace What:="_", Replacement:="0", ReplaceFormat:=False ' suche zellen nach __ und erstelle eine leerzelle
Columns("G:G").Select ' wähle Spalte G
Selection.ColumnWidth = 3 ' spaltenbreite 3
Range("G1:G55").Select ' markiere nur zellen 1-55
Selection.Interior.ColorIndex = 15 ' Zellfarbe grau
Sheets(ziel).Range("C1").Select
ActiveCell.FormulaR1C1 = "2705"
Selection.Font.Bold = True
Sheets(ziel).Range("D1").Select
ActiveCell.FormulaR1C1 = "2735"
Selection.Font.Bold = True
Sheets(ziel).Range("E1").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "2760"
Sheets(ziel).Range("F1").Select
ActiveCell.FormulaR1C1 = "2785"
Selection.Font.Bold = True
Sheets(ziel).Range("C56:C109").Select
Selection.Cut Destination:=Sheets(ziel).Range("D2:D55")
Sheets(ziel).Range("C110:C163").Select
Selection.Cut Destination:=Sheets(ziel).Range("E2:E55")
Sheets(ziel).Range("C164:C217").Select
Selection.Cut Destination:=Sheets(ziel).Range("F2:F55")
Sheets(ziel).Range("A1").Select
Sheets(ziel).Range("H1").Select
ActiveCell.FormulaR1C1 = "2705 zu 2735"
Selection.Font.Bold = True
Sheets(ziel).Range("I1").Select
ActiveCell.FormulaR1C1 = "2735 zu 2760"
Selection.Font.Bold = True
Sheets(ziel).Range("J1").Select
ActiveCell.FormulaR1C1 = "2760 zu 2785"
Selection.Font.Bold = True
'Dim lngRow As Long
For lngRow = 2 To 55 ' Zeilenauswahl = Zeile 2 bis 55
If IsNumeric(Cells(lngRow, 4).Text) And IsNumeric(Cells(lngRow, 3).Text) Then _
Cells(lngRow, 8).Value = Cells(lngRow, 4).Value - Cells(lngRow, 3).Value ' suche in Spalte D=4 und 3=c nach einem Numerischen Wert
Next ' und schreibe ergebnis in Spalte H=9 von D4-D3 wenn eine Zelle kein
' kein numerischer Wert lasse zelle frei
For lngRow = 2 To 55
If IsNumeric(Cells(lngRow, 5).Text) And IsNumeric(Cells(lngRow, 4).Text) Then _
Cells(lngRow, 9).Value = Cells(lngRow, 5).Value - Cells(lngRow, 4).Value
Next
For lngRow = 2 To 55
If IsNumeric(Cells(lngRow, 6).Text) And IsNumeric(Cells(lngRow, 5).Text) Then _
Cells(lngRow, 10).Value = Cells(lngRow, 6).Value - Cells(lngRow, 5).Value
Next
Rows("28:41").Select ' zeilen 28 - 41 auswählen
Selection.Font.ColorIndex = 5 ' mit Textfarbe 5(blau) ausführen
Rows("42:55").Select ' zeilen 42 - 55 auswählen
Selection.Font.ColorIndex = 10 ' mit Textfarbe 10 (grün) ausführen
Columns("A:IV").EntireColumn.AutoFit ' Spalten A - IV ausrichten nach Datensatzlänge
Range("A1:F1").Select
Selection.HorizontalAlignment = xlLeft ' Zellen A1 bis F1 links ausgerichtet
Application.Run "Kim_1.xls!diagramm1"
Application.Run "Kim_1.xls!diagramm2"
End If
Next i
End With
End Sub
Sub diagramm() ' Diagrammerstellung immer für das aktive Arbeitsblatt
Dim ber As Range ' aktives Blatt als ber
Dim n1$, n2$, n3$, n4$ ' Definieren bestimmter Variablen zur späteren Zellzuweisung
Set ber = ActiveSheet.Range("A2:A55,C2:F55") ' Werte für Diagramm aus aktiven Blatt
n1 = ActiveSheet.[c1] ' Variablen dem aktiven Blatt + Zelle zuweisen
n2 = ActiveSheet.[d1]
n3 = ActiveSheet.[e1]
n4 = ActiveSheet.[f1]
Charts.Add
ActiveChart.ChartType = xlLineMarkers
ActiveChart.SetSourceData Source:=ber _
, PlotBy:=xlColumns ' Sourceblatt als ber einsetzen
ActiveChart.SeriesCollection(1).Name = n1 ' Diagrammbeschriftung
ActiveChart.SeriesCollection(2).Name = n2
ActiveChart.SeriesCollection(3).Name = n3
ActiveChart.SeriesCollection(4).Name = n4
End Sub
Sub diagramm1()
Dim ber As Range, blN$
Dim n1$, n2$, n3$, n4$
blN = ActiveSheet.Name
With ActiveSheet
Set ber = .Range("A2:A55,H2:J55")
n1 = .[h1]
n2 = .[i1]
n3 = .[j1]
End With
Charts.Add
With ActiveChart
.ChartType = xlLineMarkers
.SetSourceData Source:=ber, PlotBy:=xlColumns
.SeriesCollection(1).Name = n1
.SeriesCollection(2).Name = n2
.SeriesCollection(3).Name = n3
.HasTitle = True
.ChartTitle.Characters.Text = blN
.Location Where:=xlLocationAsObject, Name:=blN
ActiveSheet.ChartObjects("Diagramm 1").Activate
ActiveChart.ChartArea.Select
ActiveSheet.Shapes("Diagramm 1").IncrementLeft 183#
ActiveSheet.Shapes("Diagramm 1").IncrementTop 87#
End With
Application.SendKeys "{esc}"
Application.ScreenUpdating = True
Set ber = Nothing
End Sub
Sub diagramm2()
Dim ber As Range, blN$
Dim n1$, n2$, n3$, n4$
blN = ActiveSheet.Name
With ActiveSheet
Set ber = .Range("A2:A55,C2:F55")
n1 = .[c1]
n2 = .[d1]
n3 = .[e1]
n4 = .[f1]
End With
Charts.Add
With ActiveChart
.ChartType = xlLineMarkers
.SetSourceData Source:=ber, PlotBy:=xlColumns
.SeriesCollection(1).Name = n1
.SeriesCollection(2).Name = n2
.SeriesCollection(3).Name = n3
.SeriesCollection(4).Name = n4
.HasTitle = True
.ChartTitle.Characters.Text = blN
.Location Where:=xlLocationAsObject, Name:=blN
ActiveSheet.ChartObjects("Diagramm 2").Activate
ActiveChart.ChartArea.Select
ActiveSheet.Shapes("Diagramm 2").IncrementLeft -183#
ActiveSheet.Shapes("Diagramm 2").IncrementTop -87#
End With
Application.SendKeys "{ESC}"
Application.ScreenUpdating = True
Set ber = Nothing
End Sub
