Rucksack einfüllen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Rucksack einfüllen

23.06.2020 09:09:59

Ramon

Nachfrage..

23.06.2020 12:31:33

UweD

AW: Nachfrage..

23.06.2020 15:01:08

Ramon

AW: Nachfrage..

24.06.2020 16:45:47

UweD

AW: Nachfrage..

24.06.2020 17:14:13

UweD

AW: Nachfrage..

24.06.2020 18:18:43

Ramon

AW: Rucksack einfüllen

23.06.2020 17:34:39

onur

AW: Rucksack einfüllen

23.06.2020 17:52:29

Ramon

Hallo
Kannst du in den einzelnen Blätter die Einträge in den Spalten B bis C
in jeder Zeile ergänzen? und ggf. unsichtbar (weiß auf weiß) darstellen

Gross

	B	C	D	E	F	G
6	Gross					0,365
7	Gross	Rund				0,14
8	Gross	Rund	Rot			0,07
9	Gross	Rund	Rot	XCPO	Gegenstand	0,02
10	Gross	Rund	Rot	THGG	Gegenstand
11	Gross	Rund	Rot	JDKF	Gegenstand	0,03
12	Gross	Rund	Rot	BVJG	Gegenstand	0,02
13
14
15	Gross	Rund	Grün			0,04
16	Gross	Rund	Grün	POKHD	Gegenstand
17	Gross	Rund	Grün	THG	Gegenstand	0,02
18	Gross	Rund	Grün	JUCJ	Gegenstand	0,02
19
20
21	Gross	Rund	Gelb			0,03
22	Gross	Rund	Gelb	KDHC	Gegenstand	0,015
23	Gross	Rund	Gelb	CMNJD	Gegenstand	0,003
24	Gross	Rund	Gelb	OJDHH	Gegenstand
25	Gross	Rund	Gelb	OKD	Gegenstand	0,002
26	Gross	Rund	Gelb	POS	Gegenstand	0,01
27
28	Gross	Eckig				0,13
29	Gross	Eckig	Rot			0,015
30	Gross	Eckig	Rot	DAFF	Gegenstand	0,015
31
32
33	Gross	Eckig	Grün			0,07
34	Gross	Eckig	Grün	PSDFF	Gegenstand	0,01
35	Gross	Eckig	Grün	BJCD	Gegenstand
36	Gross	Eckig	Grün	MMW	Gegenstand	0,06
37

Das würde die Sache wesentlich erleichtern
LG

Hallo
habe mal was gebastelt..
In den Einzelblättern waren überflüssige Zeilen drin, die habe ich rausgeworfen.


Option Explicit
Sub Rucksack()
Dim TB As Worksheet, TBx As Worksheet, Groesse As String
Dim I As Integer
Dim LR As Integer, LRx As Integer, Zeile1 As Integer, Zeilen As Integer
Dim Anz As Integer, TMP
Set TB = Sheets("Rucksack")
Application.ScreenUpdating = False
With TB
LR = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte
For I = LR To 3 Step -1
Anz = Len(.Cells(I, 1)) - Len(Replace(.Cells(I, 1), "_", "")) 'Anzahl Merkmale
If Anz = 2 And .Cells(I, 1)  2 And .Cells(I, 3) = "" Then
TMP = Split(.Cells(I, 1), "_")
Groesse = TMP(0) 'Blattname
Set TBx = Sheets(Groesse)
If TBx.AutoFilterMode Then TBx.AutoFilterMode = False ' Autofilter ausschalten
LRx = TBx.Cells(TBx.Rows.Count, 1).End(xlUp).Row
'Temporäre Bezeichnung für Filter
TBx.Cells(5, 1) = "Tmp"
'Filtern
With TBx.Cells(5, 1).Resize(LRx - 4, 3)
.AutoFilter Field:=1, Criteria1:=TB.Cells(I, 1).Value
.AutoFilter Field:=3, Criteria1:=""
End With
'Anzahl gefilterte Zeilen 'Headline abziehen
Zeilen = WorksheetFunction.CountIf(TBx.Columns(1), TB.Cells(I, 1)) - 1
Select Case Zeilen
Case -1, 0
'Kein Eintrag, oder nur Headline
'tue nichts
Case 1, 2
Zeile1 = WorksheetFunction.Match(TB.Cells(I, 1), TBx.Columns(1), 0) + 1
.Cells(I - 1, 1).Resize(Zeilen, 7).Value = TBx.Cells(Zeile1, 1).Resize( _
Zeilen, 7).Value
Case Is > 2
'Zusätzliche Einfügezeilen erzeugen
Zeile1 = WorksheetFunction.Match(TB.Cells(I, 1), TBx.Columns(1), 0) + 1
.Rows(I).Resize(Zeilen - 2).Insert xlDown
.Cells(I - 1, 1).Resize(Zeilen, 7).Value = TBx.Cells(Zeile1, 1).Resize( _
Zeilen, 7).Value
End Select
I = I - 1
TBx.AutoFilterMode = False
TBx.Cells(5, 1).ClearContents ' Temp wieder leeren
End If
Next
End With
Application.ScreenUpdating = True
End Sub

https://www.herber.de/bbs/user/138538.xlsm
LG UweD

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread