suchen und weitersuchen
31.01.2016 08:11:02
Sigi
ich möchte nach einem Begriff suchen, Makro ausführen und weitersuchen.
Leider weiss ich nicht wie ich das bewerkstelligen muß.
In Anlage Musterdatei zum besseren Verständnis.
Danke!
Gruß, Sigi
https://www.herber.de/bbs/user/103161.xlsm
Option Explicit
Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32.dll" ( _
ByRef pArray() As Any) As Long
Dim lSp As Long, lSp1 As Long
Dim lRe As Long
Dim ii As Long
Private Sub CommandButton1_Click()
Dim arr()
Dim iRowU As Integer
Dim Anz As Integer
Dim Z As Integer
Dim AufAnz As Integer
Dim wksD As Object
Dim wksA As Object
Set wksD = Sheets("Data")
Set wksA = Sheets("Auswahl")
With wksA
For ii = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(1, 2), .Cells(ii, 6)).Clear
Next ii
End With
With wksD
lSp = .Rows(1).Find(what:="ANG_P_NR", LookIn:=xlValues, lookat:=xlWhole).Column
lSp1 = .Rows(1).Find(what:="ANG_ANZAHL", LookIn:=xlValues, lookat:=xlWhole).Column
For ii = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If Not IsEmpty(.Cells(ii, 1)) And .Cells(ii, lSp) = UF1.cboProjNr.Value Then
lRe = ii
AufAnz = .Cells(lRe, lSp1).Value
Anz = lSp1 + 1
For Z = 1 To AufAnz
wksA.Cells(Z, 1) = .Cells(lRe, Anz)
wksA.Cells(Z, 2) = .Cells(lRe, Anz + 1)
wksA.Cells(Z, 3) = .Cells(lRe, Anz + 2)
wksA.Cells(Z, 4) = .Cells(lRe, Anz + 3)
wksA.Cells(Z, 5) = .Cells(lRe, Anz + 4)
wksA.Cells(Z, 6) = .Cells(lRe, Anz + 5)
Anz = Anz + 7
Next Z
End If
Z = Z + AufAnz
AufAnz = .Cells(lRe, lSp1).Value
Next ii
End With
With wksA
For ii = 1 To .Cells(Rows.Count, 4).End(xlUp).Row
If Not IsEmpty(.Cells(ii, 4)) Then
ReDim Preserve arr(0 To 6, 0 To iRowU)
arr(0, iRowU) = .Cells(ii, 1)
arr(1, iRowU) = FormatNumber(.Cells(ii, 2), 2)
arr(2, iRowU) = .Cells(ii, 3)
arr(3, iRowU) = .Cells(ii, 4)
arr(4, iRowU) = FormatNumber(.Cells(ii, 5), 2)
arr(5, iRowU) = FormatNumber(.Cells(ii, 6), 2)
arr(6, iRowU) = " "
iRowU = iRowU + 1
End If
Next ii
End With
With UF1
If SafeArrayGetDim(arr) 0 Then .lstAng.Column = arr
End With
End Sub
Private Sub UserForm_Initialize()
Dim dic As Object
Dim xKey As Variant
With Sheets("Data")
lSp = .Rows(1).Find(what:="ANG_P_NR", LookIn:=xlValues, lookat:=xlWhole).Column
Set dic = CreateObject("scripting.dictionary")
For ii = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If Not IsEmpty(.Cells(ii, lSp)) Then
xKey = .Cells(ii, lSp).Value
dic(xKey) = 0
End If
Next
For Each xKey In dic
UF1.cboProjNr.AddItem xKey
Next
dic.RemoveAll
Set dic = Nothing
End With
UF1.cboProjNr.ListIndex = -1
End Sub