Namen verteilen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

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

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 »

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

Beliebteste Forumthreads (12 Monate)

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread