AW: Makro mit Cursorpositionswechsel aufrufen
16.03.2017 16:31:01
Christian
Hallo Matthias,
das läuft so leider noch nicht.
Hier mal alle VBA codes:
Public Sub ChartVorschau()
'Bei Knopfdruck aus Ribbon aktivieren bis Knopf AUS gedrückt wird.
'Variablen deklarieren
Dim Zeile As Integer
Dim Spalte As Integer
Dim Werte As Integer
Dim i As Integer 'Anzahl der Werte bzw. max. 50 Stück
Dim AnzahlWerte As Integer
Dim AnzahlLetzteBefüllteZeile As Integer
Dim Anzahl_iO As Integer
Dim Anzahl_niO As Integer
Dim x As Integer 'Zeilenindex für die Position an der eingefügt werden soll
Dim ZuKopierendeZeile As Integer
Dim c As Integer 'Zeilenindex an der Position die kopiert werden soll
x = 9 'in diesem Zeilenindex befindet sich die Startposition
'Cursorposition feststellen um aus dieser Spalte die Werte zu übertragen
Spalte = ActiveCell.Column
Zeile = ActiveCell.Row
'überttrage Werte laut Cursorposition
Application.ScreenUpdating = False
ActiveSheet.Cells(8, Spalte).Copy 'Nennmaß
Sheets("ChartSource").Select
Range("B9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Massblatt").Select
Cells(Zeile, Spalte).Select
'OTG festlegen
ActiveSheet.Cells(9, Spalte).Copy
Sheets("ChartSource").Select
Range("H7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Massblatt").Select
Cells(Zeile, Spalte).Select
'UTG festlegen
ActiveSheet.Cells(10, Spalte).Copy
Sheets("ChartSource").Select
Range("I7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Massblatt").Select
Cells(Zeile, Spalte).Select
'Letzte befüllte Zelle finden in der Spalte laut Cursor Position & iO und niO Werte _
ausschließen
AnzahlLetzteBefüllteZeile = ActiveSheet.Cells(Rows.Count, Spalte).End(xlUp).Row - 16
Anzahl_iO = Application.WorksheetFunction.CountIf(ActiveSheet.Columns(Spalte), "i.O.")
Anzahl_niO = Application.WorksheetFunction.CountIf(ActiveSheet.Columns(Spalte), "n.i.O.")
' MsgBox AnzahlLetzteBefüllteZeile
' MsgBox ("Anzahl iO " & Anzahl_iO & _
' " Anzahl niO " & Anzahl_niO)
AnzahlWerte = AnzahlLetzteBefüllteZeile ' - (Anzahl_iO + Anzahl_niO)
' MsgBox AnzahlWerte
If AnzahlWerte 0
c = ZuKopierendeZeile - i
' MsgBox c
ActiveSheet.Cells(c, Spalte).Select
If IsNumeric(ActiveSheet.Cells(c, Spalte)) Then
ActiveSheet.Cells(c, Spalte).Copy
Sheets("ChartSource").Select
Cells(x, 5).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Massblatt").Select
Cells(Zeile, Spalte).Select
i = i - 1
x = x + 1
Else
i = i - 1
End If
Loop
'Chart auf Messblatt anzeigen
Sheets("ChartSource").Select
ActiveSheet.ChartObjects("Diagramm 1").Activate
Application.CutCopyMode = False
ActiveChart.Location Where:=xlLocationAsObject, Name:="Massblatt"
ActiveSheet.ChartObjects("Diagramm 1").Activate
ActiveSheet.Shapes("Diagramm 1").Left = 10
ActiveSheet.Shapes("Diagramm 1").Top = 40
ActiveSheet.Shapes("Diagramm 1").Height = 200
ActiveSheet.Shapes("Diagramm 1").Width = 350
Sheets("Massblatt").Select
Cells(Zeile, Spalte).Select
End Sub
'Refresh bei Cursorbewegung
'vor dem Refresch Befehl "ChartSource" Range("E9:E58") leer machen.
'Bei Refresch Befehl Chart Übertragung überspringen
Public Sub Refresch()
ActiveSheet.ChartObjects("Diagramm 1").Activate
Application.CutCopyMode = False
ActiveChart.Location Where:=xlLocationAsObject, Name:="ChartSource"
ActiveSheet.ChartObjects("Diagramm 1").Activate
ActiveSheet.Shapes("Diagramm 1").Left = 500
ActiveSheet.Shapes("Diagramm 1").Top = 200
ActiveSheet.Shapes("Diagramm 1").Height = 200
ActiveSheet.Shapes("Diagramm 1").Width = 350
Range("E9:E58").Value = ""
Sheets("Massblatt").Select
Call ChartVorschau
End Sub
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
Call Refresch
End Sub
Danke