title image


Smiley Makro angepasst
Hi,



ich habe noch 2 kleine Erweiterungen eingebaut. Teste mal das:







Sub druckOutput()



    Dim I As Integer

    Dim J As Integer

    Dim K As Integer, Merker As Integer

    Dim Preis As Double

    Dim GesPreis As Double

    Dim EndeSpalte1 As Integer

    Dim EndeZeile1 As Integer

    Dim Nameda As Boolean

    Dim Verskos As Double



    Worksheets("OutPut").Columns("A:E").ClearContents

    EndeZeile1 = Cells(1, Columns.Count).End(xlToLeft).Column

    EndeSpalte1 = Cells(Rows.Count, 1).End(xlUp).Row

    K = 0

    For I = 4 To EndeZeile1

        K = K + 1

        GesPreis = 0

        Nameda = False

        For J = 9 To EndeSpalte1

            If Not IsEmpty(Cells(J, I).Value) Then

               Preis = Cells(J, 3).Value * Cells(J, I).Value

               GesPreis = GesPreis + Preis

               If Nameda = False Then

                  Worksheets("OutPut").Cells(K, 1).Value = Cells(1, I).Value

                  Merker = K

                  Nameda = True

                  K = K + 1

               End If

               Worksheets("OutPut").Cells(K, 1).Value = Cells(J, 1).Value

               Worksheets("OutPut").Cells(K, 2).Value = Cells(J, 2).Value

               Worksheets("OutPut").Cells(K, 3).Value = Cells(J, 3).Value

               Worksheets("OutPut").Cells(K, 4).Value = Cells(J, I).Value

               Worksheets("OutPut").Cells(K, 5).Value = Preis

               K = K + 1

            End If

        Next J

        If Nameda Then

        Verskos =[r7] * Cells(5, I) / 100

        GesPreis = GesPreis + Verskos

            Worksheets("OutPut").Cells(Merker, 5).Value = GesPreis

            If Verskos > 0 Then

                Worksheets("OutPut").Cells(K, 2).Value = "Anteilige Versandkosten"

                Worksheets("OutPut").Cells(K, 5).Value = Verskos

                K = K + 1

            End If

        Else

           K = K - 1

        End If

    Next I



    With Worksheets("OutPut").Columns("A:E").Font

         .Size = 8

         .Bold = True

    End With

    Worksheets("OutPut").Columns("C:C").NumberFormat = "$#,##0.00_);($#,##0.00)"

    Worksheets("OutPut").Columns("E:E").NumberFormat = "$#,##0.00_);($#,##0.00)"

    Worksheets("OutPut").Columns("A:E").AutoFit



End Sub









Code eingefügt mit Syntaxhighlighter 4.0






Gruß, Matthias


geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: