[VBA] Zell-Bereich abhängig von Inhalt übertragen

[Rabe]

Hi,

ich habe in einem Zellbereich (B4:CW103) einer Hilfstabelle entweder eine 0 oder eine Zahl.
Im Controlling-Blatt steht in manchen Zellen ein Datum, alle anderen sind Leerzellen.
Nun sollen im Controlling-Blatt die Leerzellen entweder mit einem "-" gefüllt werden oder leer bleiben, abhängig von der korrespondierenden Zelle der Hilfstabelle.

Mit

Code:

  With Sheets("Controlling")
     .Unprotect 'Passwort
     'Übertragen der Inhalte der Hilfstabelle
     For j = 2 To 101                             '100 Spalten: B bis CW
        For i = loMatrixStart To loMatrixEnde     '100 Zeilen: 4 bis 103
           'wenn im Controlling-Blatt ein Datum steht, soll das Datum bleiben
           If Not IsDate(Sheets("Controlling").Cells(i, j)) Then
              'wenn eine Zahl in der Hilfstabelle steht, soll die Zahl übertragen werden, bei 0 ein "-"
              If Sheets("Hilfstabelle").Cells(i, j).Value > 0 Then
                 .Cells(i, j).Value = .Cells(i, j).Value
              Else
                 .Cells(i, j).Value = "-"
              End If
           End If
        Next i
     Next j
     .Protect 'Passwort
  End With

geht es, dauert aber lange.

Wie kann ich das beschleunigen?

Mit

Code:

     Range("B4:CW103").SpecialCells(xlCellTypeBlanks) = 0
     .Range("B4:CW103").SpecialCells(xlCellTypeConstants, xlTextValues).ClearContents

kann ich sehr schnell in alle leeren Zellen eine 0 schreiben oder Zellen mit "-" leer machen, gibt es so etwas auch für alle Zellen, die kein Datum enthalten?

[Helvetier]

Hallo Ralf
Dein Problem habe ich nur soweit verstanden, als es schnell gehen soll. Was immer das heisst: In der Ewigkeit wird das Zeitalter "Mensch" auch schnell sein. Aber hier habe ich einen Code gefunden (den ich natürlich nicht getestet habe und der zurechtgestutzt werden muss für Dein Problem): Man schreibt da von 10'000 in weniger als 1 sec
'''www.ms-office-forum.net/forum/showthread.php?t=296305

Code:

Sub KundeBox()
Dim objArrLst
Dim arrKunde() As Variant
Dim L As Long
Dim scrDic, TempArr
Dim wksD As Worksheet
Dim letzte As String, strTmp As String
Dim c As Integer, i As Integer
Const Trenner As String = "#"
Set wksD = ThisWorkbook.Worksheets("Datenbank")
Set scrDic = CreateObject("Scripting.dictionary")
letzte = wksD.Cells(Rows.Count, "B").End(xlUp).Row
arrKunde = wksD.Range("A2:C" & letzte)
   For L = 1 To UBound(arrKunde)
       strTmp = ""
       For i = 1 To UBound(arrKunde, 2)
           strTmp = strTmp & arrKunde(L, i) & Trenner
       Next
       If UCase(arrKunde(L, 1)) = "X" Then
           scrDic(strTmp) = 0
       End If
   Next
  TempArr = scrDic.keys
Erase arrKunde
'Größe des arrays Kunde setzen
ReDim Preserve arrKunde(scrDic.Count - 1, 1)
For L = 0 To scrDic.Count - 1
   arrKunde(L, 1) = Split(TempArr(L), Trenner)(1)
   arrKunde(L, 0) = Split(TempArr(L), Trenner)(2)
Next
Set scrDic = Nothing
QuickSortMultiDim arrKunde, 2 '***Modul aufrufen um nach Namen zu sortieren

   With Me.Kunde
       .ColumnCount = 2
       .ColumnWidths = "4cm;1cm"
       .List = arrKunde
   End With
End Sub