Thema
|
Datum
|
Von Nutzer
|
Rating
|
Antwort
|
|
14.12.2020 02:29:13 |
Sebastian |
|
|
|
14.12.2020 10:15:50 |
volti |
|
|
|
14.12.2020 11:58:25 |
Ulrich |
|
|
|
14.12.2020 12:01:56 |
Gast32764 |
|
|
|
14.12.2020 17:33:20 |
volti |
|
|
|
14.12.2020 19:25:50 |
Gast90153 |
|
|
|
14.12.2020 19:43:24 |
volti |
|
|
|
14.12.2020 20:02:45 |
Sebastian |
|
|
|
15.12.2020 00:47:45 |
volti |
|
|
|
15.12.2020 01:32:41 |
Sebastian |
|
|
|
15.12.2020 09:50:05 |
volti |
|
|
|
15.12.2020 14:47:55 |
Sebastian |
|
|
Makro mit vielen Tabellenblättern |
15.12.2020 15:19:33 |
volti |
|
|
|
15.12.2020 16:05:40 |
volti |
|
|
|
28.02.2021 23:46:30 |
Sebastian |
|
|
|
01.03.2021 09:22:12 |
volti |
|
|
Von:
volti |
Datum:
15.12.2020 15:19:33 |
Views:
752 |
Rating:
|
Antwort:
|
Thema:
Makro mit vielen Tabellenblättern |
Hi,
noch eine Idee....
Wir führen noch ein Array sArrSuch ein.
Diese werden mit dem Blattnamen wie gehappt gefüllt und die wenigen nicht passenden nach der Einlesung noch mal verändert
sArrSuch(15)="AndererText"
oder Du sucht je Blatt ein Feld aus (kann ausgeblendet oder weiß auf weiß sein) und füllst hier die Suchbegriffe ein...
Code:
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71 |
|
Option Explicit
Option Compare Text
Sub Gesamt()
Dim i As Long, j As Long
Dim sArrBlatt() As String, sArrList() As String, sArrSuch() As String
Dim iNotfound As Long, iZeile() As Long, iAnz As Long
' Speed ein
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
' Einlesen der Tabellenblattnamen und Listobjektnamen in Array
For j = 1 To ThisWorkbook.Worksheets.Count
With ThisWorkbook.Worksheets(j)
If Not .Name Like "GSV" And .ListObjects.Count > 0 Then
ReDim Preserve sArrBlatt(i)
ReDim Preserve sArrList(i)
ReDim Preserve sArrSuch(i)
sArrBlatt(i) = .Name
sArrSuch(i) = .Name ' Oder z.B. von einem ein Feld =Range("A1").value
sArrList(i) = .ListObjects(1)
i = i + 1
End If
End With
Next j
ReDim iZeile(UBound(sArrBlatt))
' Löschen der Datenbereiche aller Tabellen
For j = 0 To UBound(iZeile)
With ThisWorkbook.Worksheets(sArrBlatt(j)).ListObjects(sArrList(j))
If .ListRows.Count >= 1 Then .DataBodyRange.Delete
End With
Next j
' Übertragen der Daten
With ThisWorkbook.Worksheets("GSV").ListObjects("Tabelle1").DataBodyRange
For i = 1 To .Rows.Count
For j = 0 To UBound(iZeile)
If sArrSuch(j) Like "*" & .Cells(i, 2).Value & "*" Then
iZeile(j) = iZeile(j) + 1: iAnz = iAnz + 1
ThisWorkbook.Worksheets(sArrBlatt(j)).Range(sArrList(j)).Rows(iZeile(j)).Value = .Rows(i).Value
Exit For
End If
Next j
If j > UBound(iZeile) Then
iNotfound = iNotfound + 1
ThisWorkbook.Worksheets("Nicht gefunden").Rows(iNotfound).Value = .Rows(i).Value
End If
Next i
End With
' Formatieren der Spaltenbreite aller Tabellen
On Error Resume Next
For j = 0 To UBound(iZeile)
Worksheets(sArrBlatt(j)).ListObjects(sArrList(1)).Columns.AutoFit
Next j
' Speed aus
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox iAnz & " Zeilen wurden verarbeitet", vbInformation, "Datenübertragung"
End Sub
|
_________
viele Grüße
Karl-Heinz
|
- Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
- Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
- Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
- Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
- Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei
Antworten auf Ihren Beitrag zu benachrichtigen
Bitte geben Sie ein aussagekräftiges Thema an.
Bitte geben Sie eine gültige Email Adresse ein!
- Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
- Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
- Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
- Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
- Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei
Antworten auf Ihren Beitrag zu benachrichtigen
Thema
|
Datum
|
Von Nutzer
|
Rating
|
Antwort
|
|
14.12.2020 02:29:13 |
Sebastian |
|
|
|
14.12.2020 10:15:50 |
volti |
|
|
|
14.12.2020 11:58:25 |
Ulrich |
|
|
|
14.12.2020 12:01:56 |
Gast32764 |
|
|
|
14.12.2020 17:33:20 |
volti |
|
|
|
14.12.2020 19:25:50 |
Gast90153 |
|
|
|
14.12.2020 19:43:24 |
volti |
|
|
|
14.12.2020 20:02:45 |
Sebastian |
|
|
|
15.12.2020 00:47:45 |
volti |
|
|
|
15.12.2020 01:32:41 |
Sebastian |
|
|
|
15.12.2020 09:50:05 |
volti |
|
|
|
15.12.2020 14:47:55 |
Sebastian |
|
|
Makro mit vielen Tabellenblättern |
15.12.2020 15:19:33 |
volti |
|
|
|
15.12.2020 16:05:40 |
volti |
|
|
|
28.02.2021 23:46:30 |
Sebastian |
|
|
|
01.03.2021 09:22:12 |
volti |
|
|