AW: über VBA Formel in Zelle
02.01.2020 12:32:56
Albert
hallo onur,
nein nicht direkt.. da man bei verbundenen Zellen eine "0" als Ergebnis bekommt bei "=A3"
und dies funktioniert mit meiner Excel-Anwendung nicht.
Ich kann dir mal den den kompletten Code des Subs schicken, vielleicht fallen dir ja ansonsten noch Optimierungen auf ;)
ich freu mich über Feedback.
Gruß
Albert
Private Sub CommandButton3_Click()
Dim k As Integer
Dim i As Integer
Dim j As Integer
Dim s As Integer
Dim m As Integer
Dim f As Integer
Dim p As Integer
Dim Baugruppe As Variant
Dim Dname As Variant
Dname = ThisWorkbook.Name
For k = 3 To 10000
If Cells(k + 1, 2) = "" Then
Exit For
End If
Next k
k = k + 15
Windows("exp.xls").Activate 'St?ckliste aktivieren
Baugruppe = ComboBox1.Value
For i = 3 To 3000 'Schleife, wieviel Teile vorhanden in Liste vorhanden
If Cells(i, 2) = "" Then
i = i - 1
Range(Cells(3, 2), Cells(i, 12)).Select
Selection.Copy
'**Einf?gen St?ckliste
Windows(Dname).Activate 'aktuelle Excel aktivieren
Cells(k, 4).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
Exit For
End If
Next i
i = i - 2
For j = 3 To 1000
If Cells(j, 23) = Baugruppe Then
For s = 0 To 1000
If Cells(j + s + 1, 2) = 1 Or Cells(j + s + 1, 2) = "" Then
Exit For
End If
Next s
Exit For
End If
Next j
For m = 3 To 1000
If Cells(m, 23) = Baugruppe Then
Cells(m, 1).Select
Selection.UnMerge
Exit For
End If
Next m
's Anzahl vorhanden
'i Anazahl hinzugef?gt
'j Zeile vorhanden
'k Zeile hinzugef?gt
'?berpr?fen ob vorhanden
For m = j To j + s 'vorhanden
For f = k To k + i 'hinzugef?gt
If Mid(Cells(f, 4).Value, 15, 3) = "000" Then 'Wenn BGR-Namen ab 15. Stelle ein "000" _
hat, dann
Cells(f, 24).Value = "Baugruppe" 'F?ge zellen den Namen "BGR" hinzu
End If
If Cells(f, 4) = Cells(m, 4) Then
Cells(f, 29) = 1
Cells(m, 29) = 1
If Cells(f, 6) > Cells(m, 6) Then
If Cells(m, 17) "" Then
Cells(f, 6) = Cells(f, 6) - Cells(m, 6)
Cells(f, 29) = ""
Else
Cells(m, 6) = Cells(f, 6)
End If
End If
End If
Next f
Next m
'wenn nicht vorhanden, dann l?schen bzw.
For m = j To j + s
If Cells(m, 29) = "" Then
If Cells(m, 17) "" And Cells(m, 18) = "" Then
Cells(m, 28) = 1
End If
If Cells(m, 17) = "" Then
Cells(m, 2).Activate
Selection.Delete Shift:=xlUp
End If
End If
Next m
Cells(j, 1) = Baugruppe
Cells(j, 3) = "1"
For m = 3 To 1000
Cells(m, 23).FormulaLocal = "=Wenn(A" & m & """"";A" & m & "; """")"
If Cells(m + 1, 4) = "" And Cells(m + 1, 6) = "" And Cells(m + 1, 7) = "" Then
Exit For
End If
Next m
'neue Teile hinzuf?gen
p = 1
For m = 3 To 1000
If Cells(m, 4) = Baugruppe Then
If p > 1 Then
p = p + Cells(m, 6)
Else
p = Cells(m, 6)
End If
End If
If Cells(m + 1, 2) = "" Then
Exit For
End If
Next m
m = 0
For f = k To k + i
If Cells(f + m, 29) 1 Then
Cells(f + m, 25) = Cells(f + m, 6)
Cells(f + m, 6) = Cells(f + m, 6) * p
Cells(j + 1, 2).Activate
ActiveCell.EntireRow.Insert
m = m + 1
Range(Cells(f + m, 2), Cells(f + m, 22)).Copy
Cells(j + 1, 2).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range(Cells(f + m, 24), Cells(f + m, 25)).Copy
Cells(j + 1, 24).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells(j + 1, 16) = Date
End If
If Cells(f + m + 1, 4) = "" Then
Exit For
End If
Next f
Range(Cells(k + m, 1), Cells(k + i + m, 25)) = "" '***zus?tzliche Zellen ... daran muss noch _
gedacht werden
Range(Cells(3, 29), Cells(1000, 29)) = ""
'*Nummerierungen
For m = 3 To 1000
If Cells(m, 23) = Baugruppe Then
For f = 0 To 1000
Cells(m + f, 3) = f + 1
If Cells(m + f + 1, 23) "" Or (Cells(m + f + 1, 4) = "" And Cells(m + f + 1, _
6) = "" And Cells(m + f + 1, 7) = "") Then
Range(Cells(m, 1), Cells(m + f, 1)).Select
Selection.Merge
Exit For
End If
Next f
Exit For
End If
Next m
For m = 3 To 1000
Cells(m, 2) = m - 2
If Cells(m + 1, 4) = "" And Cells(m + 1, 6) = "" And Cells(m + 1, 7) = "" Then
Exit For
End If
Next m
End Sub