Mapping via VBA

Hallo, habe ein kleines Problem, von dem ich denke, dass es von einem VBA-kundigen schnell und einfach gelöst werden kann.
Habe zwei Dateien angehangen, im Prinzip soll ein einfaches Mapping via VBA realisiert werden, das unter 3 Bedingungen stattfindet (steht in der Datei). Es handelt sich um eine Lieferantenbeurteilung, bei der ich bis jetzt gut 550 Zeilen händisch verglichen und umgetragen habe. Das scheint mir ein Fall für VBA zu sein 0-:
Wer kann helfen? Vielen Dank im voraus und eine Frage an die Antwortenden:
Wie seit ihr in VBA eingestiegen. Möchte im Kontext meiner derzeitigen Arbeit gerne mehr mit VBA lösen, weiß aber nicht recht, wie ich einsteigen soll.
Einen sonnigen Nachmittag, Peter
https://www.herber.de/bbs/user/46451.xls
https://www.herber.de/bbs/user/46452.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Mapping via VBA

30.09.2007 18:21:00

Erich

AW: Mapping via VBA

30.09.2007 20:53:00

Peter

Hallo Peter,
die Prozedur gehört in ein (normales) Modul der Mappe, die du als 46451.xls hochgeladen hast.
Die Beurteilung2.xls (entspricht 46452.xls) muss offen sein.


Option Explicit
Sub Mapping()
Dim lngA As Long, wsB As Worksheet, zB As Long
Dim strM As String, dblM As Double, datM As Date, zF As Long
Set wsB = Workbooks("Beurteilung2.xls").Sheets(1)  ' Beurteilung2.xls muss offen sein
'   Set wsB = Workbooks("46452.xls").Sheets(1)
ThisWorkbook.Activate
Sheets(1).Select
lngA = Cells(Rows.Count, 1).End(xlUp).Row
Columns("A:A").Insert Shift:=xlToRight
Cells(1, 1) = "Zeile"
Range(Cells(2, 1), Cells(lngA, 1)).FormulaR1C1 = "=ROW()"
Range(Cells(2, 1), Cells(lngA, 1)) = Range(Cells(2, 1), Cells(lngA, 1)).Value
Cells(1, 1).Sort _
Key1:=Range("B2"), Order1:=xlAscending, _
Key2:=Range("M2"), Order2:=xlAscending, _
Key3:=Range("J2"), Order3:=xlAscending, _
Header:=xlYes, OrderCustom:=1, Orientation:=xlTopToBottom
zB = 1
While Not IsEmpty(wsB.Cells(zB + 1, 5))
zB = zB + 1
strM = wsB.Cells(zB, 5)
dblM = wsB.Cells(zB, 15)
datM = wsB.Cells(zB, 14)
zF = 0
On Error Resume Next
zF = WorksheetFunction.Match(strM, Range(Cells(1, 2), Cells(lngA, 2)), 0)
On Error GoTo 0
If zF > 0 Then
While strM = Cells(zF, 2) And dblM > Cells(zF, 13)
zF = zF + 1
Wend
While strM = Cells(zF, 2) And dblM = Cells(zF, 13) And datM > Cells(zF, 10) + 3
zF = zF + 1
Wend
If strM = Cells(zF, 2) And dblM = Cells(zF, 13) And _
datM >= Cells(zF, 10) - 3 And datM

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread