Zeilen kopieren und automatisch einordnen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub AddiereWoandersHin() On Error GoTo hell Dim sPath As String Dim sFile As String Dim iColFarben As Integer Dim iColWerte As Integer Dim lRowFirst As Long sPath = "C:\TestTmp" 'PFAD hier ändern! sFile = "82928.xlsx" 'DATEI hier ändern! iColFarben = 1 'in dieser SPALTE stehen die Farben (A=1, B=2 usw) iColWerte = 2 'in dieser SPALTE stehen die Werte lRowFirst = 1 'fängt in ZEILE 1 an. Hast du Überschriften im Original? Dann setze _ dies auf 2 'deine sheet-namen kann ich leider nicht verwenden ... welche Spracheinstellung hast du denn? 'Ich verwende stattdessen immer "sheet1" Dim wkbOld As Workbook Dim wkbNew As Workbook Dim lRowLast As Long Dim rFarben As Range Dim lRowFarbe As Long Dim iFehler As String Set wkbOld = ActiveWorkbook Call FileCheckOpen(sPath, sFile) Set wkbNew = ActiveWorkbook wkbOld.Activate With ActiveSheet lRowLast = .Cells(Rows.Count, iColFarben).End(xlUp).Row For Each rFarben In .Range(.Cells(lRowFirst, iColFarben), .Cells(lRowLast, iColFarben)) iFehler = rFarben.Value Debug.Print rFarben.Value lRowFarbe = Application.WorksheetFunction.Match(rFarben.Value, wkbNew.Sheets(1).Cells(1, _ iColFarben).EntireColumn, False) wkbNew.Sheets(1).Cells(lRowFarbe, iColWerte).Value = rFarben.Offset(0, 1) + wkbNew. _ Sheets(1).Cells(lRowFarbe, iColWerte).Value Next rFarben End With GoTo heaven: hell: MsgBox ("Farbe " & iFehler & " fehlt!") Resume Next heaven: End Sub '*********************************************************************************************** _ '* Makros to open needed files. Checks if Files are open or not. '* If file is already open, do nothing - else open it '* stolen from: https://www.herber.de/mailing/Pruefen_ob_Arbeitsmappe_geoeffnet_und_wenn_nein_oeffnen.htm '* modified by Klaus M.vdT. / 16.NOV.2012 '*********************************************************************************************** _ 'Example: 'Call FileCheckOpen("C:\TMP", "Filename.xls") 'path and filename can be RANGE from excelsheet Sub FileCheckOpen(sPath As String, sFile As String) sPath = sPath & "/" & sFile If WkbExists(sFile) = False Then If Dir(sPath) = "" Then MsgBox "File " & sPath & " not found!" Else Workbooks.Open sPath, UpdateLinks:=False End If Else Workbooks(sFile).Activate End If End Sub Private Function WkbExists(sFile As String) As Boolean Dim wkb As Object On Error Resume Next Set wkb = Workbooks(sFile) If Not wkb Is Nothing Then WkbExists = True End If On Error GoTo 0 End Function

Hi,
sorry ich war etwas zu schnell. Ich habs nochmal durchkommentiert (damit du auch verstehst was da passiert) und ein paar kosmetische Mänkel beseitigt.


Sub AddiereWoandersHin()
On Error GoTo hell
Dim sPath As String
Dim sFile As String
Dim iColFarben As Integer
Dim iColWerte As Integer
Dim lRowFirst As Long
sPath = "C:\TestTmp"  'PFAD hier ändern!
sFile = "82928.xlsx"  'DATEI hier ändern!
iColFarben = 1        'in dieser SPALTE stehen die Farben (A=1, B=2 usw)
iColWerte = 2         'in dieser SPALTE stehen die Werte
lRowFirst = 1         'fängt in ZEILE 1 an. Hast du Überschriften im Original? Dann setze dies  _
auf 2
'deine sheet-namen kann ich leider nicht verwenden ... welche Spracheinstellung hast du denn?
'Ich verwende stattdessen immer "sheet1"
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim lRowLast As Long
Dim rFarben As Range
Dim lRowFarbe As Long
Dim iFehler As String
Set wkbOld = ActiveWorkbook 'alte Datei merken
Call FileCheckOpen(sPath, sFile) 'neue Datei öffnen
Set wkbNew = ActiveWorkbook 'neue Datei merken (Focus auf neuer Datei nach öffnen)
With wkbOld.Sheets(1)
lRowLast = .Cells(Rows.Count, iColFarben).End(xlUp).Row                                  ' _
letzte Zeile
For Each rFarben In .Range(.Cells(lRowFirst, iColFarben), .Cells(lRowLast, iColFarben))  'fü _
r den gesamten Bereich
iFehler = rFarben.Value  'für die Fehlerbehandlung die Farbe merken
'Zeile der aktuellen Farbe im neuen Blatt feststellen (Farbe fehlt? springe zur  _
Fehlerbehandlung)
lRowFarbe = Application.WorksheetFunction.Match(rFarben.Value, wkbNew.Sheets(1).Cells(1, _
iColFarben).EntireColumn, False)
'Wert der aktuellen Farbe im neuen Blatt erhöhen
wkbNew.Sheets(1).Cells(lRowFarbe, iColWerte).Value = .Cells(rFarben.Row, iColWerte) +  _
wkbNew. _
Sheets(1).Cells(lRowFarbe, iColWerte).Value
Next rFarben
End With
GoTo heaven:
hell:
MsgBox ("Farbe " & iFehler & " fehlt!")
Resume Next
heaven:
End Sub
'*********************************************************************************************** _
_
'* Makros to open needed files. Checks if Files are open or not.
'* If file is already open, do nothing - else open it
'* stolen from: https://www.herber.de/mailing/Pruefen_ob_Arbeitsmappe_geoeffnet_und_wenn_nein_oeffnen.htm
'* modified by Klaus M.vdT. / 16.NOV.2012
'*********************************************************************************************** _
_
'Example:
'Call FileCheckOpen("C:\TMP", "Filename.xls")
'path and filename can be RANGE from excelsheet
Sub FileCheckOpen(sPath As String, sFile As String)
sPath = sPath & "/" & sFile
If WkbExists(sFile) = False Then
If Dir(sPath) = "" Then
MsgBox "File " & sPath & " not found!"
Else
Workbooks.Open sPath, UpdateLinks:=False
End If
Else
Workbooks(sFile).Activate
End If
End Sub
Private Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function

Hallo Klaus
ich verwende Excel 2007. Da reichte Set bookOut = Workbooks("82928")
Klar hätte man bei der aufgabe noch einige Informationen erfragen sollen.
Ich hab' mir das erspart und bin meiner Intuition gefolgt.
Ich lade mir erstmal die Ausgabetabelle in ein Array.
Dadurch bleibt die Ausgabe unsortiert in der bestehenden Reihenfolge.
Im Dictionary erfasse ich alle Daten-Pärchen mit key und Wert.
Die keys sind also die eindeutigen Schlüssel.
Jeder Schlüssel kann nur einmal vorkommen(logisch, sonst wäre die Zuordnung der werte ja nicht möglich).
Sollte dies doch vorkommen, dann beende ich die Sach mit strDubError. In dem Falle hätte der Fragesteller eine sinnlose Aufgabe gestellt. In der Praxis wäre dieser Fehler damit abgefangen.
Auch das Leerzeichen in "rot " habe ich nicht als böswillige Absicht gesehen, sondern als möglichen Fehler den es zu berücksicksichtigen gilt. Das passiert mitunter,wenn die Daten aus anderen Programmen importiert wurden. Deshalb habe ich alle Begriffe getrimmt.
Dictionary.TextMode = 1
Nichtbeachtung der Groß/Kleinschreibung. Auch damit wird eine mögliche Fehlerquelle beseitigt.
Danach lese ich die 1.Tabelle in das Dictionary und addiere die Werte. Das Dictionary erkennt den Schlüssel. Ich brauche also keine Schleife. Hier bin ich davon ausgegangen, dass ein Schlüssel sehr wohl mehrfach vorkommen kann. Sollte in der 1. Tabelle ein neuer Schlüssel auftauchen, dann wird er klaglos in das Dictionary aufgenommen. Das erkennt man dann daran, dass in der Ausgabe am Ende der Tabelle weitere Zahlen auftauchen. Diesen "Fehler?" habe ich nicht behoben.
So, und zuguterletzt werden dann die Werte ausgegeben.
Zum scripting.dictionary möchte ich mich nicht weiter auslassen, da findest du genug Lektüre, zB.:
http://www.microsoft.com/germany/technet/datenbank/articles/600356.mspx
Ich hätte die vba.collection nehmen können oder system.collections.arraylist. Alles Klassen, die Daten-Pärchen verarbeiten.
regular expressions dient dem schnellen und komplexen Mustervergleich, ist also was ganz anderes. Auf Elemente anderer Sprachen greife ich zu, weil diese ihre Vorteile haben, Schnelligkeit und Eigenschaften, die es in vba so nicht gibt. Die Klasse 'regular expressions' gibt es in verschieden Sprachen, so auch in wscript und im Net.Framework.
Gruß
Rudi

Beliebteste Forumthreads (12 Monate)

Zeilen kopieren und automatisch einordnen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen kopieren und automatisch einordnen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread