Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Namen verteilen | Herbers Excel-Forum


Betrifft: Namen verteilen von: Markus
Geschrieben am: 11.02.2012 08:19:36

Hallo,
wöchentlich erstelle ich einen Kostenstellenbericht.
In der Tabelle Stamm, stehen von A2 bis B1200 Kostenstellen und Namen
z.B.
A1 B1
1123 Meier, Franz
112A
1180 Feierabend, Hans
etc.
Dazu gibt es 30 Tabellen, mit den gleichnamigen Tabellen-Name 1123,1112A, 1180 etc.
Ein Makro soll nun die Namen aus der Liste Stamm in die Tabellen, 1123 .. 1180 verteilen.
Die Namen in den Tabellen 1123.. 1180 beginnen bei A8.
Pro Register 1123..1180 sind Maximum 16 Namen zu verteilen.
In den Registern, sind die Zellen von A8 bis A23 vor Beginn des Makro's bereits leer.
Danke jetzt schon und schönen Samstag.
Markus

  

Betrifft: Namen verteilen ... Frage von: Matthias L
Geschrieben am: 11.02.2012 08:48:01

Hallo

Ich hab das so verstanden.

Du willst 16 Namen aus der Tabelle("Stamm").Spalte(B)
in die Tabelle("1123") schreiben (ab A8), wenn sie zur Kostenstelle 1123 gehören ?
Weiter dann 16 Namen einer anderen Kostenstelle in das nächste Blatt mit dem Registenamen dieser Kostenstelle?
Bleiben Namen übrig?
Was soll passieren wenn es z.B mal nur 13 Namen einer Kostestelle gibt?

Lad doch bitte eine Bsp-Datei mit dem Blatt("Stamm") hoch.
Ich glaube es hat niemand Lust 30*16 Namen zu erfinden.

Gruß Matthias


  

Betrifft: AW: Namen verteilen ... Frage von: Markus
Geschrieben am: 11.02.2012 09:17:25

https://www.herber.de/bbs/user/78855.xls

Hallo,
hier ein Beispiel.
Ich habe Daten und Tabellenanzahl reduziert, damit das ganze nicht zu gross wird.
Danke
Markus


  

Betrifft: AW: Namen verteilen ... Frage von: Markus
Geschrieben am: 11.02.2012 09:49:30

Hallo Matthias,
ich habe doch die Tabelle gesendet, oder hat das nicht funktioniert?
Danke
Markus


  

Betrifft: Namen verteilen ... Antwort von: Matthias L
Geschrieben am: 11.02.2012 09:55:37

Hallo

https://www.herber.de/bbs/user/78856.xls

Gruß Matthias


  

Betrifft: AW: Namen verteilen ... Frage von: Markus
Geschrieben am: 11.02.2012 10:12:04

Hallo Matthias,

fast!
Die Idee sollte eigentlich sein, dass das Makro die Tabelle "Stamm" von A2 bis A?? ( meist ca.300 Einträge) und die Daten automatisch auf alle existierenden Tabellen verteilt. Also keine Abfrage welche Tabelle gefüllt werden soll.
(Momentan habe ich eine Mappe mit 29 Tabellen 1110,111A bis 3399).
In der Tabelle Stamm existieren momentan 348 Sätze ( A1:B349).
Entschuldigung, dass es hier ein Missverständnis gegeben hat.
Markus


  

Betrifft: AW: Namen verteilen ... Nachtrag von: Markus
Geschrieben am: 11.02.2012 10:15:25

Es ist sichergestellt, dass die Tabelle Stamm sortiert ist, nach KST und dann nach Namen.


  

Betrifft: AW: Namen verteilen ... Frage von: Tino
Geschrieben am: 11.02.2012 10:17:11

Hallo,
kannst mal diesen Code testen.

Sub Verteilen()
Dim ArrayD(), ArrayAus()
Dim oDicTKST As Object, varKey
Dim n&, nn&, nCount&
Dim FehlerTab$

Set oDicTKST = CreateObject("Scripting.Dictionary")

With Sheets("Stamm")
    ArrayD = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2).Value2
End With

For n = 1 To Ubound(ArrayD)
    oDicTKST(CStr(ArrayD(n, 1))) = 0
Next n

For Each varKey In oDicTKST.keys
    If CheckTab(varKey) Then
        Redim Preserve ArrayAus(1 To 1, 1 To Ubound(ArrayD))
        For nn = 1 To Ubound(ArrayD)
            If CStr(ArrayD(nn, 1)) = varKey Then
                nCount = nCount + 1
                ArrayAus(1, nCount) = ArrayD(nn, 2)
            End If
        Next nn
        Redim Preserve ArrayAus(1 To 1, 1 To nCount)
        Sheets(varKey).Cells(7, 1).Resize(nCount) = Application.Transpose(ArrayAus)
        Erase ArrayAus
        nCount = 0
    Else
        FehlerTab = FehlerTab & vbCr & Chr(7) & " " & varKey
    End If
Next varKey

If FehlerTab <> "" Then
    MsgBox "Für diese Kostenstellen wurde keine Tabelle gefunden!" & vbCr & FehlerTab, vbExclamation
End If

End Sub

Function CheckTab(ByVal strTabName$) As Boolean
On Error Resume Next
CheckTab = Sheets(strTabName).Index > 0
End Function
Gruß Tino


  

Betrifft: AW: Namen verteilen ... Frage von: Markus
Geschrieben am: 11.02.2012 10:42:44

Hallo Tino,
Deine Version funktioniert am besten, bloss A8, das als freie Zeile nicht beschrieben werden sollte,
wird mit dem ersten Namen beschrieben - Schade.
Aber sonst, besten Dank!
Markus


  

Betrifft: AW: Namen verteilen ... Frage von: Tino
Geschrieben am: 11.02.2012 10:57:31

Hallo,
mach aus cells(7,1) einfach Cells(8,1)

Gruß Tino


  

Betrifft: Super, dieses Forum von: Markus
Geschrieben am: 11.02.2012 11:04:04

Hallo Tino,
nachdem ich neu im Forum geschrieben habe,
bin ich selbst auf die Idee gekommen.
Super, das ganz erspart mir jede Woche eine halbe Stunde Arbeit.
Danke an Euch alle
Markus


  

Betrifft: AW: Namen verteilen ... Frage von: Josef Ehrensberger
Geschrieben am: 11.02.2012 10:31:26


Hallo Markus,

teste mal.

' **********************************************************************
' Modul: Modul4 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub sortInSheets()
  Dim rng As Range, rngInput As Range
  Dim lngNext As Long
  
  With Sheets("Stamm")
    For Each rng In .Range("A2:A" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
      If rng <> "" Then
        If IsValidSheetName(rng.Text) Then
          Set rngInput = FirstEmptyCell(Sheets(rng.Text).Range("A8:A23"))
          rngInput = rng.Offset(0, 1)
        End If
      End If
    Next
  End With
  
End Sub


Public Function IsValidSheetName(ByVal strName As String) As Boolean
  Dim objRegExp As Object
  
  Set objRegExp = CreateObject("vbscript.regexp")
  
  With objRegExp
    .Global = True
    .Pattern = "^[^\/\\:\*\?\[\]]{1,31}$"
    .IgnoreCase = True
    IsValidSheetName = .test(strName)
  End With
  
  Set objRegExp = Nothing
  
End Function


Public Function FirstEmptyCell(Target As Range) As Range
  Dim vntRet As Variant
  With Target
    vntRet = Evaluate("MIN(IF('" & .Parent.Name & "'!" & .Address & "="""",ROW('" & _
      .Parent.Name & "'!" & .Address & ")+COLUMN('" & .Parent.Name & "'!" & _
      .Address & ")*10^-6))")
    If IsError(vntRet) Or vntRet = 0 Then Exit Function
    Set FirstEmptyCell = .Cells(Clng(Split(vntRet, ",")(0)) - .Rows(1).Row + 1, _
      Clng(Split(vntRet, ",")(1)) - .Columns(1).Column + 1)
  End With
End Function






« Gruß Sepp »



  

Betrifft: AW: Namen verteilen ... Frage von: Markus
Geschrieben am: 11.02.2012 10:40:57

Hallo Sepp,
bei Deinem Makro kommt ein Fehler bei:

Public Function FirstEmptyCell1(Target As Range) As Range
  Dim vntRet As Variant
  With Target
    vntRet = Evaluate("MIN(IF('" & .Parent.Name & "'!" & .Address & "="""",ROW('" & _
      .Parent.Name & "'!" & .Address & ")+COLUMN('" & .Parent.Name & "'!" & _
      .Address & ")*10^-6))")
    If IsError(vntRet) Or vntRet = 0 Then Exit Function
    ' hier blockt das Makro ab
    '
    Set FirstEmptyCell = .Cells(CLng(Split(vntRet, ",")(0)) - .Rows(1).Row + 1, _
      CLng(Split(vntRet, ",")(1)) - .Columns(1).Column + 1)
  End With
End Function

Gruss
Markus


  

Betrifft: AW: Namen verteilen ... Frage von: Josef Ehrensberger
Geschrieben am: 11.02.2012 10:42:59


Hallo Markus,

kann ich nicht nachvollziehen.

https://www.herber.de/bbs/user/78858.xls





« Gruß Sepp »



  

Betrifft: AW: Namen verteilen ... Frage von: Markus
Geschrieben am: 11.02.2012 10:48:00

Hallo Sepp,
vermutlich liegt das Problem an meinem Add-In,
bei meiner Frau am PC funktioniert das Ding!
Danke
Markus


  

Betrifft: Namen verteilen - meine Version mit MiniCode von: Matthias L
Geschrieben am: 12.02.2012 11:44:01

Hallo

https://www.herber.de/bbs/user/78871.xls

Gruß Matthias


Beiträge aus den Excel-Beispielen zum Thema "Namen verteilen"