Live-Forum - Die aktuellen Beiträge
Datum
Titel
24.04.2024 00:20:14
Bestimmte Spalten als xls exportieren per Makro
23.04.2024 22:08:10
Auflisten in Spalte VBA
23.04.2024 21:33:46
Nur farbige/nicht farbige Zellen markieren
23.04.2024 21:29:56
Bestimmte Zellen auf andere Arbeitsblätter kopieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1524to1528
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1524to1528
1524to1528
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Werte übertragen

Werte übertragen
11.11.2016 09:41:05
Berndt
Hallo zusammen,
im angehängten Bsp. übertrage ich Themen aus einen Speicher auf einzelen Mitarbeiter.
https://www.herber.de/bbs/user/109334.xlsm
Die zuordnung bisher funktionierte duch einen Abgleich der Sheetnamen mit den Namen in den Speicher. Waren z.B. Sheetname "Herr A" und im Speicher "Herr A" ein Treffer, wurde das dazugehörige Thema in SheetName "Herr A" übertragen.
Doch nun habe ich im Speicher das "Herr" wegemacht.
Das Makro kann nun unmöglich einen Vergleich treffen das die Sheetnamen immernoch mit Herr beginnen.
Ich hoffe ihr könnt mir behilflich sein.
Wenn der Button "Themen an Mitarbeiter übertragen" betätigt wird, so sieht man auch gleich was das Problem ist.
Nämlich der Ausdruck "Sheets(a(i, 3))"
VG Berndt

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Werte übertragen
11.11.2016 10:24:24
Max2
Vielleicht so ?

Dim intLänge As Integer
intLänge = Len(a)
For Each Ws In ThisWorkbook.Sheets
If Right(Ws.Name, intLänge) = a Then
bis = Sheets(Ws.Name).Range("B2000").End(xlUp).Row + 1
End If
Next Ws

AW: Werte übertragen
11.11.2016 10:51:00
Berndt
Danke für deine Antwort.
Habe das Makro folgendermaßen angepasst
Private Sub CommandButton3_Click()
' Themen auf Mitarbeiter verteilen
Dim a
Dim i           As Long
Dim bis         As Long
Dim von         As Long
Dim Treffer     As Range
Dim Ws          As Worksheet
Dim FindStr     As String
Dim maxZell     As Long
Dim c           As Range
Dim rng         As Range
Dim Zell        As Range
Dim intLänge    As Integer
Application.ScreenUpdating = False
Set Treffer = Worksheets("Themenspeicher").Columns(2).Find("*Themenspeicher*", LookIn:= _
xlValues)
von = Treffer.Row + 1  'erste Zelle nach Themenspeicher in Sheet Themenspeicher
bis = Worksheets("Themenspeicher").Range("B" & Rows.Count).End(xlUp).Row + 1
a = Range("B" & von & ":F" & bis)
intLänge = Len(a)
For Each Ws In ThisWorkbook.Sheets
For i = 1 To UBound(a)
If a(i, 2) = "x" Then
If Right(Ws.Name, intLänge) = a Then
bis = Sheets(Ws.Name).Range("B2000").End(xlUp).Row + 1
bis1 = Sheets(a(i, 4)).Range("C2000").End(xlUp).Row + 1
Ab = Application.Match("aus Themenspeicher übertragen", Worksheets(Ws.Name).Range(" _
B:B"), 0)
Ab1 = Application.Match("Termin", Worksheets(a(i, 4)).Range("C:C"), 0)
'Doppelte Werte werden vermieden
If IsError(Application.Match(a(i, 1), Worksheets(Ws.Name).Range("B" & Ab & ":B"  _
& bis), 0)) _
& IsError(Application.Match(a(i, 4), Worksheets(Ws.Name).Range("C" & Ab1 & ":C"  _
& bis1), 0)) _
Then
Sheets(Ws.Name).Range("B" & bis) = a(i, 1)
Sheets(Ws.Name).Range("C" & bis) = a(i, 4)
Sheets(Ws.Name).Range("B8:C8").Copy  ' da ist das gleiche Format
Sheets(Ws.Name).Range("B" & bis).Resize(, 2).PasteSpecial xlFormats
Sheets(Ws.Name).Range("B" & bis).HorizontalAlignment = xlLeft
Sheets(Ws.Name).Range("C" & bis).NumberFormat = "dd.mm.yyyy"
End If
End If
End If
Next
Next Ws
Es crasht aber schon bei intLänge = Len(a) (Laufzeitfehler 13: Typen unverträglich)
Anzeige
AW: Werte übertragen
11.11.2016 11:57:42
Max2
Ja hab nicht gesehen dass a ein Range ist.
Len() geht nur mit einem String
Hier blick ich nicht ganz durch, was genau macht das bzw. was willst du damit bewirken/machen ? 

bis = Sheets(Ws.Name).Range("B2000").End(xlUp).Row + 1
bis1 = Sheets(a(i, 4)).Range("C2000").End(xlUp).Row + 1

AW: Werte übertragen
11.11.2016 12:30:41
Berndt
mit bis / Ab und bis1 / Ab1 steuere ich 
If IsError(Application.Match(a(i, 1), Worksheets(a(i, 3)).Range("B" & Ab & ":B" & bis), 0)) _
& IsError(Application.Match(a(i, 4), Worksheets(a(i, 3)).Range("C" & Ab1 & ":C" & bis1), 0)) _
D.h. ich schaue in die Namenssheets (a(i, 3)) oder jetzt Ws.Name und schaue, ob ich das Thema (Application.Match(a(i, 1)) darin schon stehen habe und gleiche Aktion dann noch mit den Terminen (Application.Match(a(i, 4)).
Wenn IsError (also nein; bzw. das Thema in Verbindung mit den Termin wurde bei dem Mitarbeiterblatt noch nicht gefunden) dann führe das makro weiter aus.
Habe ich das verständlich erklärt? Ich hoffe doch. ^^
VG
Anzeige
AW: Werte übertragen
11.11.2016 13:41:22
Max2
Hm ok also du guckst einfach nur ob das Thema übereinstimmt usw.
Das mit a und UBound usw. würde ich anders machen.
Ich würde einfach mit einer Variablen die Letzte beschriebene Zeile finden und die entsprechende Spalte angeben(guck dir lngZeile und rngBereich an)
In dem Bereich würde ich dann nach Zellen mit Wert "x" suchen, wenn x gefunden dann ist die Variable sName der Wert in der Zelle Rechts neben "x".
Durch die Variable sName habe ich dann meinen Namen und dann kann ich die Worksheets nach dem Namen durchsuchen usw. usw. 

Dim a
Dim sName As String
Dim i, von , bis, intLänge, maxZell As Long
Dim rngZelle, rngBereich As Range
Dim Ws, Themen As Worksheet
Dim wbkHier As Workbook
Dim lngZeile As Long
Application.ScreenUpdating = False
Set wbkHier = ThisWorkbook
Set Themen = wbkHier.Sheets("Themenspeicher")
With Themen
lngZeile = .Cells.SpecialCells(xlCellTypeLast).Row
Set rngBereich = Themen.Range(.Cells(5, 3), .Cells(lngZeile, 3)
For Each rngZelle In rngBereich
If rngZelle.Value = "x" Then
sName = rngZelle.Offset(, 1).Value
intLänge = Len(sName)
If Right(Ws.Name, intLänge) = sName Then
bis = Sheets(Ws.Name).Range("B2000").End(xlUp).Row + 1

Anzeige
AW: Werte übertragen
11.11.2016 14:19:30
Berndt
klingt auf jedenfall einleuchtend.
Habe allerding immernoch einen Laufzeitfehler 424 mit drinnen.
Objekt erforderlich bei: (If Right(Ws.Name, intLänge) = sName Then
(komisch nur damit schon alle Objekte definiert sind)
    Dim Treffer     As Range
Dim FindStr     As String
Dim c           As Range
Dim rng         As Range
Dim Zell        As Range
Dim sName As String
Dim i, von, bis, intLänge, maxZell As Long
Dim rngZelle, rngBereich As Range
Dim Ws, Themen As Worksheet
Dim wbkHier As Workbook
Dim lngZeile As Long
Application.ScreenUpdating = False
Set wbkHier = ThisWorkbook
Set Themen = wbkHier.Sheets("Themenspeicher")
Set Treffer = Themen.Columns(2).Find("*Themenspeicher*", LookIn:=xlValues)
von = Treffer.Row + 1  'erste Zelle nach Themenspeicher in Sheet Themenspeicher
bis = Themen.Range("B" & Rows.Count).End(xlUp).Row + 1
a = Range("B" & von & ":F" & bis)
With Themen
lngZeile = .Cells.SpecialCells(xlCellTypeLastCell).Row
Set rngBereich = Themen.Range(.Cells(5, 3), .Cells(lngZeile, 3))
For Each rngZelle In rngBereich
If rngZelle.Value = "x" Then
sName = rngZelle.Offset(, 1).Value
intLänge = Len(sName)
If Right(Ws.Name, intLänge) = sName Then
bis = Sheets(Ws.Name).Range("B2000").End(xlUp).Row + 1
bis1 = Sheets(a(i, 4)).Range("C2000").End(xlUp).Row + 1
Ab = Application.Match("aus Themenspeicher übertragen", Worksheets(Ws. _
Name).Range("B:B"), 0)
Ab1 = Application.Match("Termin", Worksheets(a(i, 4)).Range("C:C"), 0)
'Doppelte Werte werden vermieden
If IsError(Application.Match(a(i, 1), Worksheets(a(i, 3)).Range("B"  _
& Ab & ":B" & bis), 0)) _
& IsError(Application.Match(a(i, 4), Worksheets(a(i, 3)).Range("C" & _
Ab1 & ":C" & bis1), 0)) _
Then
Sheets(Ws.Name).Range("B" & bis) = a(i, 1)
Sheets(Ws.Name).Range("C" & bis) = a(i, 4)
Sheets(Ws.Name).Range("B8:C8").Copy  ' da ist das gleiche Format
Sheets(Ws.Name).Range("B" & bis).Resize(, 2).PasteSpecial xlFormats
Sheets(Ws.Name).Range("B" & bis).HorizontalAlignment = xlLeft
Sheets(Ws.Name).Range("C" & bis).NumberFormat = "dd.mm.yyyy"
End If
End If
End If
Next
End With

Anzeige
AW: Werte übertragen
11.11.2016 15:17:19
Max2
Sorry mein Fehler.
Ws.Name, darunter kann er sich in der Version des Codes nichts vorstellen
Es muss noch: 
For Each Ws In wbkHier.Sheets
If Right(Ws.Name, intLänge).....

rein.
Und Next Ws. erst wenn alles Überprüft und ausgeführt wurde
Eine Schleife eben
es funktioniert fast...
14.11.2016 12:59:00
Berndt
Vielen Dank.
ich habe hier den Code jetzt nochmal ins Bsp. gebracht.
https://www.herber.de/bbs/user/109405.xlsm
Ich habe bspw. mal nur die ersten 2 Themen vor zu übertragen.
Wenn man jetzt den Button "Themen übertragen" betätigt, wirfst es alle Themen zum ersten Mitarbeiter.
Die Logik dahinter verstehe ich nicht ganz?
Müssen die Schleifen getauscht werden?
VG Berndt
Anzeige

Links zu Excel-Dialogen

CommandButton

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige