Excel - VBA - Spalten eifügen - Felder abfragen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

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

Beliebteste Forumthreads (12 Monate)

Excel - VBA - Spalten eifügen - Felder abfragen

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread