|
Hallo nochmal
In Tabelle1 habe ich mal dein Beispiel nachgebaut.
In ein Modul das hier
1 2 3 4 5 6 7 8 9 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 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | Option Explicit
Sub DBC()
Dim TB1 As Worksheet, TB2 As Worksheet, LR As Long, LC As Integer
Dim MeL As String, SyL As String
Dim Sp As Integer, ArrM, ArrS, Z As Long
Dim i As Integer, j As Integer
Dim WF
Set TB1 = Sheets("Tabelle1")
Set TB2 = Sheets("Tabelle2")
Application.ScreenUpdating = False
Set WF = WorksheetFunction
MeL = InputBox("Beispiel:", "Eingabe Message Line", "BO_Land, Kontinent")
SyL = InputBox("Beispiel:", "Eingabe Syntax Line", "SG_Stadt, Fluss, Temperatur")
ArrM = Split(Mid(MeL, 4), ",")
ArrS = Split(Mid(SyL, 4), ",")
With TB2
.UsedRange.Delete
TB1.UsedRange.Copy .Cells(1, 1)
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
.Columns(1).Resize(, 2).Insert
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Sort.SortFields.Clear
For j = LBound(ArrM) To UBound(ArrM)
If WF.CountIf(.Rows(1), Trim(ArrM(j))) > 0 Then
If Sp = 0 Then
Sp = WF.Match(Trim(ArrM(j)), .Rows(1), 0)
.Sort.SortFields.Add2 Key:=.Columns(Sp), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
End If
Else
MsgBox "Fehler: " & ArrM(j) & " nicht gefunden"
.UsedRange.Delete
Exit Sub
End If
Next
With .Sort
.SetRange TB2.UsedRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = LR To 2 Step -1
If .Cells(i - 1, Sp) <> .Cells(i, Sp) Then
.Rows(i).Copy
.Rows(i + 1).Insert xlDown
.Cells(i + 1, 1) = Z
.Cells(i + 1, 2) = "BO_"
.Cells(i, 1) = Z
.Cells(i, 2) = "SG_"
Z = Z + 1
For j = LC To 3 Step -1
If InStr(MeL, .Cells(1, j)) = 0 Then
.Cells(i + 1, j).Delete xlToLeft
End If
If InStr(SyL, .Cells(1, j)) = 0 Then
.Cells(i, j).Delete xlToLeft
End If
Next
Else
.Cells(i, 1) = Z
.Cells(i, 2) = "SG_"
For j = LC To 3 Step -1
If InStr(SyL, .Cells(1, j)) = 0 Then
.Cells(i, j).Delete xlToLeft
End If
Next
End If
Next
.Sort.SortFields.Clear
.Sort.SortFields.Add2 Key:=.Columns(1), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=.Columns(2), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange TB2.UsedRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Rows(1).Delete xlUp
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Cells(1, 1).Resize(LR, 1)
.FormulaR1C1 = _
"=CONCATENATE(RC[1],RC[2],"", "",RC[3],"", "",RC[4],"", "",RC[5],"", ""&RC[6]&"", "",RC[7],"", "",RC[8])"
.Value = .Value
End With
.Columns(2).Resize(, LC).Delete
.Activate
End With
End Sub
|
Ergibt dann in Tabelle2 das hier
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | BO_Ungarn, Europa, , , , ,
SG_Budapest, Donau, 27, , , ,
BO_Spanien, Europa, , , , ,
SG_Barcelona, Tajo, 27, , , ,
SG_Madrid, , 27, , , ,
BO_Kanada, Zentralamerika, , , , ,
SG_Toronto, Fraser River, 19, , , ,
BO_Frankreich, Europa, , , , ,
SG_Paris, Rhône, 20, , , ,
SG_Marseille, Seîne, 20, , , ,
BO_Deutschland, Europa, , , , ,
SG_Stuttgart, Elbe, 20, , , ,
SG_München, Spree, 20, , , ,
SG_Hambur, Isar, 20, , , ,
BO_China, Asien, , , , ,
SG_Peking, Amur, 18, , , ,
BO_Amerika, Zentralamerika, , , , ,
SG_New York, Hudson, 24, , , ,
|
die , bei Bedarf noch löschen
LG UweD
|