besser:
07.12.2012 09:26:11
Klaus
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