Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1792to1796
1792to1796
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Excel - VBA - Spalten eifügen - Felder abfragen

Forumthread: Excel - VBA - Spalten eifügen - Felder abfragen

Excel - VBA - Spalten eifügen - Felder abfragen
17.11.2020 14:35:03
Hilfert
Erst einmal hallo zusammen,
als Neuling hier sage ich allen zuerst vielen Dank für Eure bisherige Hilfe!
Bis jetzt habe meine ganze VBA-Probleme mit Eure Hilfe lösen können.
Aber für mein weiteres Problem finde ich keine Lösung auf den Forum-Seiten.
Ich habe eine große Tabelle mit folgenden Spalten
Name1, Str1, PLZ1, Ort1, Artikel_Nummer_1,…bis, Artikel_Nummer_n, Name2, Str2, PLZ2, Ort2
In Feldern Artikel_nummer_1… steht immer die Anzahl der Artikeln.
Jetzt müssen die kompletten Spalten Name2, Str2, PLZ2, Ort2 verschoben werden direkt hinter Ort1 und
vor jede Spalte Artikel_Nummer_1 bis Artikel_Nummer_n muss eine leere Spalte eingefügt werden. Diese Spalte muss gefüllt werden mit der Spaltenüberschrift (also Artikel_Nummer_1)
Aber die Anzahl der Spalten mit Artikel_Nummer ist immer variabel, mal 20 mal 66.
Habe eine Tabelle angehangen – ist für mich einfacher zu erklären.
https://www.herber.de/bbs/user/141631.xlsx
Und ich habe keine Ahnung, wie ich das machen kann (ich kenne mich nicht so gut mit VBA)
Kann mir hierzu jemand helfen?
Dankeschön
Beata
Anzeige

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
17.11.2020 15:51:15
Nepumuk
Hallo Beata,
teste mal:
Option Explicit

Public Sub Transformieren()
    
    Dim objCell As Range
    Dim lngName2 As Long, lngOrt2 As Long, lngOrt1 As Long
    Dim lngColumn As Long, lngCounter As Long
    
    Set objCell = Rows(1).Find(What:="Ort1", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
    If objCell Is Nothing Then
        Call MsgBox("Ort1 nicht gefunden.", vbExclamation, "Programmabbruch")
        Exit Sub
    End If
    lngOrt1 = objCell.Column
    
    Set objCell = Rows(1).Find(What:="Ort2", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
    If objCell Is Nothing Then
        Call MsgBox("Ort2 nicht gefunden.", vbExclamation, "Programmabbruch")
        Exit Sub
    End If
    lngOrt2 = objCell.Column
    
    Set objCell = Rows(1).Find(What:="Name2", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
    If objCell Is Nothing Then
        Call MsgBox("Name2 nicht gefunden.", vbExclamation, "Programmabbruch")
        Exit Sub
    End If
    lngName2 = objCell.Column
    
    Call Range(Cells(1, lngName2), Cells(1, lngOrt2)).EntireColumn.Cut
    Call Cells(1, lngOrt1 + 1).Insert(Shift:=xlShiftToRight)
    
    lngColumn = 9
    
    Do
        
        lngCounter = lngCounter + 1
        
        Call Columns(lngColumn + 1).Insert(Shift:=xlShiftToRight)
        
        Call Range(Cells(2, lngColumn), Cells(Rows.Count, lngColumn).End(xlUp)).Copy(Destination:=Cells(2, lngColumn + 1))
        
        Range(Cells(2, lngColumn), Cells(Rows.Count, lngColumn).End(xlUp)).Value = Cells(1, lngColumn).Value
        
        Cells(1, lngColumn).Value = "ArtikelNummer" & CStr(lngCounter)
        
        Cells(1, lngColumn + 1).Value = "ArtikelAnzahl" & CStr(lngCounter)
        
        lngColumn = lngColumn + 2
        
    Loop Until IsEmpty(Cells(1, lngColumn).Value)
    
End Sub

Gruß
Nepumuk
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
17.11.2020 16:48:10
Hilfert
Hallo Nepumuk,
danke für die super schnelle Antwort, aber es kommt sofort:
Call MsgBox("Ort1 nicht gefunden.", vbExclamation, "Programmabbruch")
und das wars.
Lg
Beata
AW: Excel - VBA - Spalten eifügen - Felder abfragen
17.11.2020 16:53:54
Nepumuk
Hallo Beata,
ich habe mich an deine Mustermappe gehalten. Was ist in deiner Mappe anders?
Gruß
Nepumuk
Anzeige
probiere auch das
17.11.2020 16:45:38
ralf_b
versuch das auch mal. würde mich interessieren ob es das auch tut.
Sub Spaltenverschieben()
Dim i As Long
Dim rng As Range
Dim rFund As Range
Dim lcol As Long
Dim lrow As Long
application.screenupdating = false
lcol = Cells(1, Columns.Count).End(xlToLeft).Column
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A1").Resize(, lcol)
Set rFund = rng.Find(what:="Name2", LookIn:=xlValues, lookat:=xlWhole)
If Not rFund Is Nothing Then
rFund.Resize(, 4).EntireColumn.Cut
Columns("E:E").Insert Shift:=xlToRight
End If
For i = lcol To 8 Step -1
If IsNumeric(Cells(1, i).Value) Then
Cells(1, i).EntireColumn.Insert Shift:=xlToRight
Range(Cells(2, i), Cells(lrow, i)).Value = Cells(1, i).Offset(, 1).Value
Cells(1, i).Value = "Artikelnummer" & i - 8
Cells(1, i).Offset(, 1).Value = "Artikelanzahl" & i - 8
End If
Next
application.screenupdating = true
set rng = nothng : set rfund = nothing
End Sub

gruß
RB
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
17.11.2020 17:12:43
Edmund
Ich hätte auch noch einen im Angebot:
Sub Makro()
Dim a As Integer
Dim i As Integer
Dim s As Integer
Dim s1 As Integer
Dim z As Integer
z = Cells(1, 1).End(xlDown).Row
s = Cells(1, 1).End(xlToRight).Column
Range(Columns(s - 3), Columns(s)).Cut
Columns("E:H").Insert Shift:=xlToRight
s1 = 9
For i = 9 To s
Columns(s1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
s1 = s1 + 2
Next i
s1 = s1 - 1
a = 1
For i = 10 To s1 Step 2
Cells(1, i - 1).Value = Cells(1, i).Value
Range(Cells(2, i - 1), Cells(z, i - 1)).Value = Cells(1, i).Value
Cells(1, i - 1).Value = "ArtikelNummer" & a
Cells(1, i).Value = "ArtikelAnzahl" & a
a = a + 1
Next i
End Sub

Ist recht Simpel und setzt deshalb voraus, dass Deine Tabelle ein exaktes Format einhält.
Heißt:
Überschrift in Zeile 1
Erster Datensatz in Zeile 2
Der 1. Artikel in Spalte E
und die 2. Adresse ganz am Ende (umfasst 4 Spalten)
Dann sollte das funktionieren
Gruß
Edmund
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
18.11.2020 09:08:12
Hilfert
Hallo zusammen,
mein Problem ist, dass die Anschriften nicht immer an gleichen Stellen stehen.
Das was rot hinterlegt ist kann mal mehr mal weniger sein (beginnt aber immer mit 5*)
https://www.herber.de/bbs/user/141653.xlsx
Es geht darum:
1. die R_* Spalten hinter den L_* Spalten zu schieben (die Anschriften sehen immer so aus) und
2. vor jeder roten Spalte eine leere Spalte einzufügen und in diese Spalte in jeder Zelle die 5* Nummer aus der Überschrift zu schreiben
Aber Achtung: die "roten" Spalten sind immer variabel!
Ich hoffe, dass ich jetzt mein Problem richtig darstellen konnte.
LG
Beata
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
18.11.2020 09:43:15
Nepumuk
Hallo Beata,
teste mal:
Option Explicit

Public Sub Transformieren()
    
    Dim lngItem1 As Long, lngItem2 As Long
    Dim lngColumn As Long, lngCounter As Long
    Dim objCell As Range
    
    Application.ScreenUpdating = False
    
    For lngColumn = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        
        If Left$(Cells(1, lngColumn).Text, 1) = "5" Then
            
            If lngItem1 = 0 Then lngItem1 = lngColumn
            
        Else
            
            If lngItem1 <> 0 Then
                
                lngItem2 = lngColumn - 1
                Exit For
                
            End If
        End If
    Next
    
    
    Call Range(Cells(1, lngItem1), Cells(1, lngItem2)).EntireColumn.Cut
    Call Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Insert(Shift:=xlShiftToRight)
    
    Set objCell = Rows(1).Find(What:="5*", After:=Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
    
    lngColumn = objCell.Column
    
    Set objCell = Nothing
    
    Do
        
        lngCounter = lngCounter + 1
        
        Call Columns(lngColumn + 1).Insert(Shift:=xlShiftToRight)
        
        Call Range(Cells(2, lngColumn), Cells(Rows.Count, lngColumn).End(xlUp)).Copy(Destination:=Cells(2, lngColumn + 1))
        
        Range(Cells(2, lngColumn), Cells(Rows.Count, lngColumn).End(xlUp)).Value = Cells(1, lngColumn).Value
        
        Cells(1, lngColumn).Value = "ArtikelNummer" & CStr(lngCounter)
        
        Cells(1, lngColumn + 1).Value = "ArtikelAnzahl" & CStr(lngCounter)
        
        lngColumn = lngColumn + 2
        
    Loop Until IsEmpty(Cells(1, lngColumn).Value)
    
    Application.ScreenUpdating = True
    
End Sub

Gruß
Nepumuk
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
18.11.2020 09:52:17
Hilfert
Hallo Nepumuk,
Danke!!!! Ich könnte Dich knutschen !!!! Es funktioniert!!!!
Vielen leiben Dank!!!!
Beata
AW: Excel - VBA - Spalten eifügen - Felder abfragen
18.11.2020 10:42:05
Hilfert
Hallo Nepumuk,
könntest Du noch folgendes in die Procedure einbauen?
Aus diesen 3 Zeilen 1 Zeile erstellen und die Namen ändern (für mich ist sehr schwer die Variable-Spaltenanzahl abfragen)
FIRMA in L_Name_1
ORGANISATIONSEINHEIT / EMPFÄNGER ind L_Name_2
ANSPRECHPARTNER L_Name_2
ANSCHRIFT in L_Straße
PLZ in L_PLZ
ORT in L_Ort
AP-NR. in L_Ref.
und die "hinteren" Anschriften
FIRMA in R_Name_1
ORGANISATIONSEINHEIT / EMPFÄNGER ind R_Name_2
ANSPRECHPARTNER R_Name_2
ANSCHRIFT in R_Straße
PLZ in R_PLZ
ORT in R_Ort
AP-NR. in R_Ref.
https://www.herber.de/bbs/user/141658.xlsx
Wäre super!!!!!
LG
Beata
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
18.11.2020 11:44:57
Nepumuk
Hallo Beata,
teste mal:
Option Explicit

Public Sub Transformieren()
    
    Dim lngItem1 As Long, lngItem2 As Long
    Dim lngColumn As Long, lngCounter As Long
    Dim strFirstNumber As String
    Dim ablnFound(1 To 7) As Boolean
    Dim objCell As Range
    
    Application.ScreenUpdating = False
    
    lngItem1 = Cells(3, 1).End(xlToRight).Column
    lngItem2 = Cells(3, Columns.Count).End(xlToLeft).Column
    
    strFirstNumber = Cells(3, lngItem1).Text
    
    Call Rows(2).Copy(Destination:=Rows(1))
    Call Cells(1, lngItem1).UnMerge
    Call Range(Cells(3, lngItem1), Cells(3, lngItem2)).Copy(Destination:=Cells(1, lngItem1))
    
    Call Rows("2:3").Delete
    
    Call Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft)).BorderAround(LineStyle:=xlContinuous)
    
    For lngColumn = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        
        Select Case UCase$(Cells(1, lngColumn).Text)
                
            Case "FIRMA"
                
                If Not ablnFound(1) Then
                    Cells(1, lngColumn).Value = "L_Name_1"
                    ablnFound(1) = True
                Else
                    Cells(1, lngColumn).Value = "R_Name_1"
                End If
                
            Case "ORGANISATIONSEINHEIT / EMPFÄNGER"
                
                If Not ablnFound(2) Then
                    Cells(1, lngColumn).Value = "L_Name_2"
                    ablnFound(2) = True
                Else
                    Cells(1, lngColumn).Value = "R_Name_2"
                End If
                
            Case "ANSPRECHPARTNER"
                
                If Not ablnFound(3) Then
                    Cells(1, lngColumn).Value = "L_Name_2"
                    ablnFound(3) = True
                Else
                    Cells(1, lngColumn).Value = "R_Name_2"
                End If
                
            Case "ANSCHRIFT"
                
                If Not ablnFound(4) Then
                    Cells(1, lngColumn).Value = "L_Straße"
                    ablnFound(4) = True
                Else
                    Cells(1, lngColumn).Value = "R_Straße"
                End If
                
            Case "PLZ"
                
                If Not ablnFound(5) Then
                    Cells(1, lngColumn).Value = "L_PLZ"
                    ablnFound(5) = True
                Else
                    Cells(1, lngColumn).Value = "R_PLZ"
                End If
                
            Case "ORT"
                
                If Not ablnFound(6) Then
                    Cells(1, lngColumn).Value = "L_Ort"
                    ablnFound(6) = True
                Else
                    Cells(1, lngColumn).Value = "R_Ort"
                End If
                
            Case "AP-NR."
                
                If Not ablnFound(7) Then
                    Cells(1, lngColumn).Value = "L_Ref."
                    ablnFound(7) = True
                Else
                    Cells(1, lngColumn).Value = "R_Ref."
                End If
        End Select
    Next
    
    Call Range(Cells(1, lngItem1), Cells(1, lngItem2)).EntireColumn.Cut
    Call Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Insert(Shift:=xlShiftToRight)
    
    Set objCell = Rows(1).Find(What:=strFirstNumber, After:=Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
    
    lngColumn = objCell.Column
    
    Set objCell = Nothing
    
    Do
        
        lngCounter = lngCounter + 1
        
        Call Columns(lngColumn + 1).Insert(Shift:=xlShiftToRight)
        
        Call Range(Cells(2, lngColumn), Cells(Rows.Count, lngColumn).End(xlUp)).Copy(Destination:=Cells(2, lngColumn + 1))
        
        Range(Cells(2, lngColumn), Cells(Rows.Count, lngColumn).End(xlUp)).Value = Cells(1, lngColumn).Value
        
        Cells(1, lngColumn).Value = "ArtikelNummer" & CStr(lngCounter)
        
        Cells(1, lngColumn + 1).Value = "ArtikelAnzahl" & CStr(lngCounter)
        
        lngColumn = lngColumn + 2
        
    Loop Until IsEmpty(Cells(1, lngColumn).Value)
    
    Application.ScreenUpdating = True
    
End Sub

Gruß
Nepumuk
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
18.11.2020 12:35:51
Hilfert
Hallo Nepumuk,
das funktioniert !
Du bist mein Held ! Dankeschön!
LG
Beata
AW: Excel - VBA - Spalten eifügen - Felder abfragen
18.11.2020 14:09:29
Hilfert
Hallo Nepumuk,
noch eins muss ich fragen: wie kann man die Zahl lngCounter immer 2 stellig ausgeben?
Cells(1, lngColumn).Value = "ArtikelNummer" & CStr(lngCounter)
Cells(1, lngColumn + 1).Value = "ArtikelAnzahl" & CStr(lngCounter)
Ich meine anstatt wie jetzt ArtikelNummer1, ArtikelNummer01.
LG
Beata
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
18.11.2020 14:22:55
Nepumuk
Hallo Beata,
so:
Cells(1, lngColumn).Value = "ArtikelNummer" & Format$(lngCounter, "00")

Cells(1, lngColumn + 1).Value = "ArtikelAnzahl" & Format$(lngCounter, "00")

Und eine Bitte für die Zukunft. Gleich alle Karten auf den Tisch. Dann muss ich mein Makro nicht x-mal ändern.
Gruß
Nepumuk
Anzeige
AW: Excel - VBA - Spalten eifügen - Felder abfragen
18.11.2020 14:38:12
Hilfert
Super!!!! Vielen lieben Dank! Und ja, sorry werde in der Zukunft drauf achten.
Beata
Format(CStr(lngCounter),"00") owt
18.11.2020 14:34:25
ralf_b

Forumthreads zu verwandten Themen

VBA - If Anweisung mehrerer Abfragen
Jana

Hallo liebes Forum!!
Ich stehe gerade komplett (mal wieder auf dem Schlauch)!..
Ich habe einen umfangreichen VBA-Code mit Arrays. Nun möchte ich, dass in der Spalte 3 geguckt wird, ob die Zahl 2,3,7,9,11 oder 13 in dieser Zelle steht. Ist einer dieser Zahlen vorhanden, dann soll eine Va...
11.09.2008 12:06:28
Thread-ID: 1009072
3 Beiträge
VBA Schleife Farbhintergrund setzen
Dieter(Drummer)

Hi VBA Spezislisten,
suche ein VBA Lösung: Der Bereich ist A4 bis AH34! Ab der aktiven Zelle sollen 3 Zellen BLAU, die nächsten 3 ROT und die nächsten 3 GRÜN Hintergrund gefärbt werden. Dann wieder mit ROT usw. beginnen. Dies soll sich max. bis Zeile 34 der aktiven Spalte wiederholen.
D...
27.04.2011 12:53:49
Thread-ID: 1211980
14 Beiträge
Anzeige
[VBA-Schleife] Worksheets öffnen und speichern
Nico

Hallo,
ich möchte mit verschiedenen Filtern mehrere Worksheets aus einer Datentabelle erstellen. Im Prinzip klappt auch alles.
Einziges Problem:
Beim automatischen erstellen & schließen der Excel-Dateien tauchen unregelmäßig Fehlermeldungen auf.
Einige erstelle Dateien in d...
26.03.2013 11:12:30
Thread-ID: 1306027
3 Beiträge
Anzeige
VBA: Mehrere If-Abfragen über Schleife?
Jana

Hi zusammen!
Ich habe (mal wieder) ein Problem und hoffe, dass ihr mir weiterhelfen könnt.
Ich habe zwei Tabellen:
Die obere Tabelle zeigt die verfügbaren Kapazitäten von vier Lagern, in die Produkte eingelagert werden können.
In der unteren Tabelle sind Liefermengen von Produk...
02.05.2013 13:03:18
Thread-ID: 1311355
9 Beiträge
Min. und max. X-Achsenbeschriftung durch VBA
Han2883

Hallo Gemeinde,
Ich habe eine einfache Frage und zwar, ich habe bereit ein Diagramm erstellt. Erwünscht wird der min. Wert und der max. Wert der X-Achsenbeschriftung mit VBA automatisch von den Zellen K13(min. Wert) und K14(max. Wert) aufgerufen, wenn man die Werte in K13 und K14 manuell än...
30.06.2014 16:38:50
Thread-ID: 1368230
9 Beiträge
VBA Schleife Zellen auswählen und selektieren
Andreas

Hallo,
trotz langem Suchen habe ich keine Lösung gefunden. Ich hoffe Ihr könnt mich helfen.
Folgende Ausgangssituation:
- Mappe „Makro“ befindet sich nur ein Button mit meiner Makro.
- In der Mappe „Daten“ befinden sich alle Informationen die selektiert und kopiert werden sollen...
08.06.2015 14:34:45
Thread-ID: 1429823
4 Beiträge
Kopieren mit VBA Schleife und Bedingung
Elmar

Hallo Experten,
ich bräuchte ein Makro, was die Inhalte einer Datei (Name "Versand") in eine zweite Datei (Name "Master") mit exakt gleicher Struktur kopiert. Das wäre ja noch einfach, aber das Makro soll vor dem Kopieren immer zuerst den Wert der Zelle "D2" aus der Datei "Versand" prüfen,...
12.03.2016 16:23:08
Thread-ID: 1481550
5 Beiträge
Exel_VBA_Begriff suchen und Wert dahinter kopieren
Alexander

Guten Tag zusammen,
ich habe jetzt ein Makro geschrieben was mir eine Datei öffnet...
Sub test() Dim Datei As String Dim Verzeichnis As String Datei = Cells(2, 2) Verzeichnis = Cells(2, 1) Workbooks.Open Verzeichnis & "\" & Datei, ReadOnly:=True ActiveWorkbook.Close SaveChanges:...
20.06.2016 11:13:44
Thread-ID: 1499886
12 Beiträge
VBA Schriftart Grundeinstellung ändern
Ludicla

Hey Profis,
ich möchte die Voreinstellung von VBA mit der Schriftart Tahoma
auf MS-Serif umstellen.
Wie muss ich wo was einstellen ?
schon mal Dank im voraus.
Gruss Ludicla
28.12.2016 09:29:48
Thread-ID: 1531985
5 Beiträge
VBA If-Abfrage
Furkan

Hallo Community,
habe folgendes Problem. Ich will 2 Textfelder nach Inhalt prüfen und je nachdem Aktionen ausführen. Aber irgendwie liefert die If-Abfrage einen falschen Rückgabewert.
Code: If Breite1.TextLength > 0 And Nachkomma1.TextLength > 0 And Nachkomma1.Value Breite1.Val...
11.03.2017 14:54:54
Thread-ID: 1546812
2 Beiträge
VBA If-Abfrage
Furkan

Hallo Community,
habe folgendes Problem. Ich will 2 Textfelder nach Inhalt prüfen und je nachdem Aktionen ausführen. Aber irgendwie liefert die If-Abfrage einen falschen Rückgabewert.
Code: If Breite1.TextLength > 0 And Nachkomma1.TextLength > 0 And Nachkomma1.Value Breite1.Val...
11.03.2017 14:55:49
Thread-ID: 1546813
2 Beiträge
Anzeige
VBA: Daten nach Begriff durchsuchen und Werte kum.
Josef

Hallo allerseits,
ich stehe vor einer Herausforderung, welche ich gerne mit einem Excel-Makro lösen möchte. Ich bin was VBA angeht noch ein Rookie und hoffe daher, hier Hilfe zu finden.
Die Beispieldatei gibt euch einen Überblick, über das was ich möchte:
https://www.herber.de/bbs/u...
01.06.2017 11:10:54
Thread-ID: 1561625
19 Beiträge
Anzeige

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige