AW: probleme/frage zum code
30.07.2014 21:43:34
Mullit
Hallo,
die Zeilen sind zum Löschen der 'Überhangdaten', wenn Du die Tabellenanzahl verringerst, oder START_COLUMN verkleinerst, da blieben vorher noch Reste stehen, zudem wurden keine Zeilen gelöscht; hab' ich noch miteingebaut...
Die boolsche Variable war doch nicht so schlecht: Leerzeilen können jetzt auch am Anfang stehen...
Bugging-Problem: uhh ja; den Fall hatte ich noch nicht abgefangen:
Option Explicit
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
ByRef pArray() As Any) As Long
Public Sub test()
Const START_ROW As Long = 2
Const START_COLUMN As Long = 3
Dim blnInit As Boolean
Dim strFirstAddress As String
Dim ialngCount As Long, ialngIndex As Long
Dim lngIncr As Long
Dim avntArray() As Variant
Dim objRange As Range
Dim wksSheet As Worksheet
With Worksheets("Daten")
For ialngIndex = START_ROW To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(ialngIndex, 1) <> vbNullString Then
ialngCount = 0
lngIncr = 0
For Each wksSheet In Worksheets
If wksSheet.CodeName <> .CodeName Then
Set objRange = wksSheet.Columns(3).Find(What:=.Cells(ialngIndex, 1), _
After:=wksSheet.Cells(wksSheet.Cells(wksSheet.Rows.Count, 3).End(xlUp).Row, 3), _
LookIn:=xlValues, LookAt:=xlWhole)
If Not objRange Is Nothing Then
strFirstAddress = objRange.Address
Do
ialngCount = ialngCount + 1
If blnInit Then
If Ubound(avntArray, 2) < ialngCount + lngIncr Then _
Redim Preserve avntArray(.Cells(.Rows.Count, 1).End(xlUp).Row - 1, _
ialngCount * 2) As Variant
Else
Redim Preserve avntArray(.Cells(.Rows.Count, 1).End(xlUp).Row - 1, _
ialngCount * 2) As Variant
End If
avntArray(ialngIndex - START_ROW, 0) = ialngCount
avntArray(ialngIndex - START_ROW, ialngCount + lngIncr) = objRange.Offset(0, -2)
lngIncr = lngIncr + 1
avntArray(ialngIndex - START_ROW, ialngCount + lngIncr) = objRange.Offset(0, -1)
Set objRange = wksSheet.Columns(3).FindNext(After:=objRange)
Loop While Not objRange Is Nothing And objRange.Address <> strFirstAddress
End If
End If
Next
If Not blnInit Then blnInit = Not blnInit
End If
Next
If .Cells(.Rows.Count, 1).End(xlUp).Row < .UsedRange.Rows.Count + 1 Then _
.Range(.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, START_COLUMN), _
.Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).ClearContents
If CBool(SafeArrayGetDim(avntArray)) Then
If 1 + Ubound(avntArray, 2) < .UsedRange.Columns.Count Then _
Redim Preserve avntArray(.Cells(.Rows.Count, 1).End(xlUp).Row - 1, _
.UsedRange.Columns.Count) As Variant
.Range(.Cells(START_ROW, START_COLUMN), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, _
START_COLUMN + Ubound(avntArray, 2))) = avntArray
Else
MsgBox "Keine Daten zur Überprüfung vorhanden!", vbExclamation
End If
End With
Set objRange = Nothing
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 12
Gruß, Mullit