Formel in VBA

Hallo,
es soll eine .csv eingelesen werden, diese dann nach einem string durchsucht werden, und alle ergebnisse zeilenweise, nach datum sortiert anzeigen.
also in tabelle 1 ist die .csv bereits importiert. (muss nicht in vba geschehen)
die tabelle ist wie folgt aufgebaut (tabelle1)
datum;Tageslicht;Raum;Nähere Raumbezeichnung;Einheit;Beschreibung;Größe
in tabelle 2 sollen nun alle zeilen ausgegeben werden, nach denen gesucht wurde.
z.b. ich such nach raum 1 sollen alle ergbnisse aus tabelle 1 in tabelle 2 dargestellt werden.
ich habe das zuerst mit einer formel probiert, leider dauert das suchen bei nur 4 räumen schon 30 sec (4 kern rechner) es sollen jedoch etwa 600 räume dazukommen.
daher dachte ich mir, es lohnt sich eher in vba zu machen, statt mit einer formel.
hier die formel:


={WENN(ZEILE('tabelle1'!1:1)>ZÄHLENWENN('tabelle1'!$C:$C;$I$1);"";INDEX('tabelle1'!A:A;  KKLEINSTE(WENN('tabelle1'!$C$1:$C$99999=$I$1;ZEILE('tabelle1'!$1:$99999));ZEILE(I1))))  }

ich gebe also den suchbegriff in I1 ein und in tabelle 1 wird gesucht.
wie gesagt, das wird bei 600 räumen vermutlich zu lange dauern, daher vielelicht besser in vba. kann mir jemand dabei helfen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub aaa() Dim oDaten As Object, arrTmp, arrDaten(), i As Long, j As Integer, n As Long, arrItems Set oDaten = CreateObject("scripting.Dictionary") arrTmp = Sheets(1).Cells(1, 1).CurrentRegion oDaten(1) = WorksheetFunction.Index(arrTmp, 1) For i = 2 To UBound(arrTmp) If arrTmp(i, 2) = Sheets(2).Cells(1, 9) Then oDaten(i) = WorksheetFunction.Index(arrTmp, i) End If Next i ReDim arrDaten(1 To oDaten.Count, 1 To 7) arrItems = oDaten.items For i = 0 To UBound(arrItems) n = n + 1 For j = 1 To 7 arrDaten(n, j) = arrItems(i)(j) Next Next With Sheets(2) .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 7).ClearContents .Cells(1, 1).Resize(UBound(arrDaten), 7) = arrDaten End With End Sub

Sub aaa() Dim oDaten As Object, arrTmp, arrDaten(), i As Long, j As Integer, n As Long, arrItems Dim x As Long Set oDaten = CreateObject("scripting.Dictionary") arrTmp = Sheets(1).Cells(1, 1).CurrentRegion oDaten(1) = WorksheetFunction.Index(arrTmp, 1) For x = 1 To 7 'durchläuft Spalte 1-7 For i = 2 To UBound(arrTmp) If arrTmp(i, x) = Sheets(2).Cells(1, 9) Then oDaten(i) = WorksheetFunction.Index(arrTmp, i) End If Next i Next x ReDim arrDaten(1 To oDaten.Count, 1 To 7) arrItems = oDaten.items For i = 0 To UBound(arrItems) n = n + 1 For j = 1 To 7 arrDaten(n, j) = arrItems(i)(j) Next Next With Sheets(2) .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 7).ClearContents .Cells(1, 1).Resize(UBound(arrDaten), 7) = arrDaten End With End Sub

Sub aaa() Dim oDaten As Object, oRaum As Object, oItem Dim arrTmp, arrDaten(), arrItems Dim i As Long, j As Integer, n As Long Dim wksRaum As Worksheet Set oDaten = CreateObject("scripting.Dictionary") Set oRaum = CreateObject("scripting.Dictionary") Application.ScreenUpdating = False arrTmp = Sheets(1).Cells(1, 1).CurrentRegion For i = 2 To UBound(arrTmp) oRaum(arrTmp(i, 3)) = 0 Next i For Each oItem In oRaum oDaten(1) = WorksheetFunction.Index(arrTmp, 1) For i = 2 To UBound(arrTmp) If arrTmp(i, 3) = oItem Then oDaten(i) = WorksheetFunction.Index(arrTmp, i) End If Next i ReDim arrDaten(1 To oDaten.Count, 1 To 7) arrItems = oDaten.items For i = 0 To UBound(arrItems) n = n + 1 For j = 1 To 7 arrDaten(n, j) = arrItems(i)(j) Next Next On Error Resume Next Set wksRaum = Worksheets("Raum " & CStr(oItem)) On Error GoTo 0 If wksRaum Is Nothing Then Set wksRaum = Worksheets.Add(after:=Sheets(Sheets.Count)) wksRaum.Name = "Raum " & oItem End If With wksRaum .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 7).ClearContents .Cells(1, 1).Resize(UBound(arrDaten), 7) = arrDaten End With oDaten.RemoveAll n = 0 Set wksRaum = Nothing Next oItem End Sub

Sub aaa() Dim oDaten As Object, arrTmp, arrDaten(), i As Long, j As Integer, n As Long, arrItems Dim x As Long Set oDaten = CreateObject("scripting.Dictionary") arrTmp = Sheets(1).Cells(1, 1).CurrentRegion oDaten(1) = WorksheetFunction.Index(arrTmp, 1) For x = 1 To 7 'durchläuft Spalte 1-7 For i = 2 To UBound(arrTmp) If arrTmp(i, x) = Sheets(2).Cells(1, 9) Then 2)

Sub aaa() Dim oDaten As Object, oRaum As Object Dim arrTmp, arrDaten(), arrItems, strMatch As String, arrMatch Dim i As Long, j As Integer, k As Integer, n As Long Dim wksRaum As Worksheet Set oDaten = CreateObject("scripting.Dictionary") Application.ScreenUpdating = False strMatch = Application.InputBox("Räume (mit ; getrennt) ?") If Len(strMatch) > 0 And strMatch "Falsch" Then arrTmp = Sheets(1).Cells(1, 1).CurrentRegion arrMatch = Split(strMatch, ";") For k = 0 To UBound(arrMatch) oDaten(1) = WorksheetFunction.Index(arrTmp, 1) For i = 2 To UBound(arrTmp) If CStr(arrTmp(i, 3)) = arrMatch(k) Then oDaten(i) = WorksheetFunction.Index(arrTmp, i) End If Next i ReDim arrDaten(1 To oDaten.Count, 1 To 7) arrItems = oDaten.items For i = 0 To UBound(arrItems) n = n + 1 For j = 1 To 7 arrDaten(n, j) = arrItems(i)(j) Next Next On Error Resume Next Set wksRaum = Worksheets("Raum " & arrMatch(k)) On Error GoTo 0 If wksRaum Is Nothing Then Set wksRaum = Worksheets.Add(after:=Sheets(Sheets.Count)) wksRaum.Name = "Raum " & arrMatch(k) End If With wksRaum .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 7).ClearContents .Cells(1, 1).Resize(UBound(arrDaten), 7) = arrDaten End With oDaten.RemoveAll n = 0 Set wksRaum = Nothing Next k End If End Sub

Sub aaa() Dim oDaten As Object, oRaum As Object Dim arrTmp, arrDaten(), arrItems, strMatch As String, arrMatch Dim i As Long, j As Integer, k As Integer, n As Long Dim wksRaum As Worksheet Set oDaten = CreateObject("scripting.Dictionary") Application.ScreenUpdating = False strMatch = Application.InputBox("Räume (mit ; getrennt) ?") If Len(strMatch) > 0 And strMatch "Falsch" Then arrTmp = Sheets(1).Cells(1, 1).CurrentRegion arrMatch = Split(strMatch, ";") For k = 0 To UBound(arrMatch) arrMatch(k) = Trim(arrMatch(k)) oDaten(1) = WorksheetFunction.Index(arrTmp, 1) For i = 2 To UBound(arrTmp) If CStr(arrTmp(i, 3)) = arrMatch(k) Then oDaten(i) = WorksheetFunction.Index(arrTmp, i) End If Next i If oDaten.Count > 1 Then ReDim arrDaten(1 To oDaten.Count, 1 To 7) arrItems = oDaten.items For i = 0 To UBound(arrItems) For j = 1 To 7 arrDaten(i + 1, j) = arrItems(i)(j) Next Next On Error Resume Next Set wksRaum = Worksheets("Raum " & arrMatch(k)) On Error GoTo 0 If wksRaum Is Nothing Then Set wksRaum = Worksheets.Add(after:=Sheets(Sheets.Count)) wksRaum.Name = "Raum " & arrMatch(k) End If With wksRaum .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 7).ClearContents .Cells(1, 1).Resize(UBound(arrDaten), 7) = arrDaten End With End If oDaten.RemoveAll Set wksRaum = Nothing Next k End If End Sub


Sub Makro1()
Sheets("Tabelle2").Select
Call aaa
Sheets("Tabelle3").Select
Call aaa
Sheets("Tabelle4").Select
Call aaa
Sheets("Tabelle601").Select
Call aaa
End Sub

Sub aaa()
Dim oDaten As Object, arrTmp, arrDaten(), i As Long, j As Integer, n As Long, arrItems
Dim x As Long
Dim mysht As String
mysht = ActiveSheet.Range("I1")
Sheets(1).Cells(1, 9) = mysht
Set oDaten = CreateObject("scripting.Dictionary")
arrTmp = Sheets(1).Cells(1, 1).CurrentRegion
oDaten(1) = WorksheetFunction.Index(arrTmp, 1)
For x = 1 To 7 'durchläuft Spalte 1-7
For i = 2 To UBound(arrTmp)
If arrTmp(i, x) = Sheets(1).Cells(1, 9) Then
oDaten(i) = WorksheetFunction.Index(arrTmp, i)
End If
Next i
Next x
ReDim arrDaten(1 To oDaten.count, 1 To 7)
arrItems = oDaten.items
For i = 0 To UBound(arrItems)
n = n + 1
For j = 1 To 7
arrDaten(n, j) = arrItems(i)(j)
Next
Next
With ActiveSheet 'Sheets(mysht)
.Range(.Cells(1, 1), .Cells(Rows.count, 1).End(xlUp)).Resize(, 7).ClearContents
.Cells(1, 1).Resize(UBound(arrDaten), 7) = arrDaten
End With
End Sub

sehr unelegand aber es würde funktionieren...
wenn noch einer das schöner machen kann, wäre ich sehr erfreut und eine funktion einbauen, dass tabelle1 davon ausgenommen ist. wenn da irgend einer mal drangeht, will ich nicht, dass meine "datenbank" üerschrieben wird

Sub Makro1() Dim a As Integer For a = 2 To 6 Sheets(a).Select Call aaa Next a End Sub Sub aaa() Dim oDaten As Object, arrTmp, arrDaten(), i As Long, j As Integer, n As Long, arrItems Dim x As Long Dim mysht As String mysht = ActiveSheet.Range("I1") Sheets(1).Cells(1, 9) = mysht Set oDaten = CreateObject("scripting.Dictionary") arrTmp = Sheets(1).Cells(1, 1).CurrentRegion oDaten(1) = WorksheetFunction.Index(arrTmp, 1) For x = 1 To 7 'durchläuft Spalte 1-7 For i = 2 To UBound(arrTmp) If arrTmp(i, x) = Sheets(1).Cells(1, 9) Then oDaten(i) = WorksheetFunction.Index(arrTmp, i) End If Next i Next x ReDim arrDaten(1 To oDaten.count, 1 To 7) arrItems = oDaten.items For i = 0 To UBound(arrItems) n = n + 1 For j = 1 To 7 arrDaten(n, j) = arrItems(i)(j) Next Next With ActiveSheet 'Sheets(mysht) .Range(.Cells(1, 1), .Cells(Rows.count, 1).End(xlUp)).Resize(, 7).ClearContents .Cells(1, 1).Resize(UBound(arrDaten), 7) = arrDaten End With End Sub

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Formel in VBA

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread