Makro kopiert, aber der Feinschliff

Sub Makro2() ' übergabe an nachweise Sheets("Nachweise").Select ActiveSheet.Unprotect Sheets("Nachweisdokumentation").Select Range("N10,O10,P10,Q10").Select Range("Q10").Activate Selection.Copy Sheets("Nachweise").Select ActiveSheet.Paste Range("E3").Select Application.CutCopyMode = False ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True Sheets("Nachweisdokumentation").Select ActiveSheet.Shapes.Range(Array("Picture 2")).Select Selection.Delete Range("P10").Select Selection.ClearContents Range("O10").Select Selection.ClearContents Range("N10").Select Selection.ClearContents Range("N11").Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Makro2() ' übergabe an nachweise Dim lRow As Long With Sheets("Nachweise") .Unprotect lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'erste freie Zeile in Spalte A Sheets("Nachweisdokumentation").Range("N10:Q10").Cut .Range("A" & lRow) .Range("A" & lRow & ":D" & lRow).Copy Sheets("Nachweisdokumentation").Range("N10").PasteSpecial xlPasteFormats 'Rahmen wieder _ herstellen .Protect 'wenn du es oben entsperrst, willst du es danach sicher wieder sperren? End With End Sub

Sub Makro2() ' übergabe an nachweise Dim lRow As Long With Sheets("Nachweise") .Unprotect lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'erste freie Zeile in Spalte A Sheets("Nachweisdokumentation").Range("Q10").Cut .Range("D" & lRow) Sheets("Nachweisdokumentation").Range("N10:P10").Copy .Range("D" & lRow).PasteSpecial xlPasteValues Sheets("Nachweisdokumentation").Range("N10:P10").ClearContents .Protect 'wenn du es oben entsperrst, willst du es danach sicher wieder sperren? End With End Sub

Hallo Uli,
nachfolgender Code informiert zum fehlenden Item und springt auch glich zur entsprechenden Stelle..

Sub Datenkopieren()

'Eingetragene Daten von Nachweisdokumentation zu Nachweise kopieren

 Dim WSh As Worksheet, AC As Range, iZeile As Long

 Dim iZl As Long, iSpalte As Integer

 Dim sShapeName As String, sGelesene As String

 Dim sMA As String, sCheck As String

 Dim oShp As Object, bCheck As Boolean

 Dim sMsgTxt As String

 Set WSh = ThisWorkbook.Sheets("Nachweisdokumentation")

'Sicherkeit

 If WSh.Cells(10, "N").Value = "" Then

    sMsgTxt = "Es wurde kein Mitarbeiter ausgewählt!"

    iSpalte = 14

 ElseIf WSh.Cells(10, "O").Value = "" Then

    sMsgTxt = "Es wurde kein Bereich eingetragen!"

    iSpalte = 15

 ElseIf WSh.Cells(10, "P").Value = "" Then

    sMsgTxt = "Es wurde kein Datum eingetragen!"

    iSpalte = 16

 Else

    For Each oShp In WSh.Shapes

     With oShp

      If .Type = 13 Then

        If .Top &GT;= WSh.Range("Q10").Top - 5 _

          And .Left &GT;= WSh.Range("Q10").Left - 5 _

          And .Left &LT; WSh.Range("R10").Left Then

          sShapeName = .Name: Exit For

        End If

      End If

     End With

    Next oShp

    If sShapeName = "" Then

       sMsgTxt = "Die Unterschrift fehlt!"

       iSpalte = 17

    End If

 End If

 If sMsgTxt &LT;&GT; "" Then

   MsgBox sMsgTxt & vbCrLf & "Bitte nachtragen!", vbCritical, "Daten übertragen"

   WSh.Cells(10, iSpalte).Select

   Exit Sub

 End If

 Application.ScreenUpdating = False

 With ThisWorkbook.Sheets("Nachweise")

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

'Ermittle alle gelesenen Dokus

   sMA = WSh.Cells(10, "N").Value

   For iZl = 2 To iZeile - 1

    If .Cells(iZl, "A").Value = sMA Then

      For iSpalte = 5 To .UsedRange.Columns.Count Step 2

          If .Cells(iZl, iSpalte).Value = "" Then Exit For

          sGelesene = sGelesene & .Cells(iZl, iSpalte).Value _

              & .Cells(iZl, iSpalte + 1).Value & ","

      Next iSpalte

    End If

   Next iZl

   .Unprotect

'Uli Bezeichnung und Index mit kopieren

   iSpalte = 5

   For iZl = 10 To 100

     If WSh.Cells(iZl, "C").Value = "" Then Exit For

     sCheck = WSh.Cells(iZl, "C").Value & WSh.Cells(iZl, "K").Value

     If InStr(sGelesene, sCheck & ",") = 0 Then

       .Cells(iZeile, iSpalte + 0).Value = WSh.Cells(iZl, "C").Value

       .Cells(iZeile, iSpalte + 1).Value = WSh.Cells(iZl, "K").Value

       iSpalte = iSpalte + 2     'wenn die Item nacheinander gezeigt werden sollen

       bCheck = True

     End If

Rem       iSpalte = iSpalte + 2  'wenn die Item passend untereinanderstehen sollen

   Next iZl

   If bCheck = True Then

'Texte kopieren und löschen

   .Range("A" & iZeile & ":C" & iZeile).Value = WSh.Range("N10:P10").Value

   WSh.Range("N10:P10").ClearContents

'Grafik suchen und kopieren

   On Error Resume Next

   WSh.Shapes.Range(Array(sShapeName)).Copy

'Grafik einfügen

    .Select

    .Paste

'Grafik in Zelle einpassen

    Set AC = .Range("$D$" & iZeile)

    If TypeName(Selection) = "Picture" Then

      With Selection.ShapeRange

         .Name = "Unterschrift"

         .LockAspectRatio = True

         If (.Width / AC.Width) &LT; (.Height / AC.Height) Then

            .Height = AC.Height          'Bild höher als breit

         Else

            .Width = AC.Width

         End If

         .Left = AC.Left + ((AC.Width - .Width) &bsol; 2)

         .Top = AC.Top + ((AC.Height - .Height) &bsol; 2)

      End With

    End If

'Blatt wieder schützen

   .Range("A1").Select

   .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

  End If

 End With

'Bereich und Bild löschen

 WSh.Select

 If bCheck Then ActiveSheet.Shapes.Range(Array(sShapeName)).Delete

 Application.ScreenUpdating = True

End Sub

Viele Grüße aus Freigericht
Karl-Heinz

Hallo Uli,
schau mal, ob das u.a. erweiterte Makro Deinem Wunsche entspricht:

Option Explicit

Sub Datenkopieren()

'Eingetragene Daten von Nachweisdokumentation zu Nachweise kopieren

 Dim WSh As Worksheet, AC As Range, iZeile As Long

 Dim iZl As Long, iSpalte As Integer

 Dim sShapeName As String, sGelesene As String

 Dim sMA As String, sCheck As String

 Dim oShp As Object, bCheck As Boolean

 Dim sMsgTxt As String

 Set WSh = ThisWorkbook.Sheets("Nachweisdokumentation")

'Sicherkeit

 If WSh.Cells(10, "N").Value = "" Then

    sMsgTxt = "Es wurde kein Mitarbeiter ausgewählt!"

    iSpalte = 14

 ElseIf WSh.Cells(10, "O").Value = "" Then

    sMsgTxt = "Es wurde kein Bereich eingetragen!"

    iSpalte = 15

 ElseIf WSh.Cells(10, "P").Value = "" Then

    sMsgTxt = "Es wurde kein Datum eingetragen!"

    iSpalte = 16

 Else

    For Each oShp In WSh.Shapes

     With oShp

      If .Type = 13 Then

        If .Top &GT;= WSh.Range("Q10").Top - 5 _

          And .Left &GT;= WSh.Range("Q10").Left - 5 _

          And .Left &LT; WSh.Range("R10").Left Then

          sShapeName = .Name: Exit For

        End If

      End If

     End With

    Next oShp

    If sShapeName = "" Then

       sMsgTxt = "Die Unterschrift fehlt!"

       iSpalte = 17

    End If

 End If

 If sMsgTxt &LT;&GT; "" Then

   MsgBox sMsgTxt & vbCrLf & "Bitte nachtragen!", vbCritical, "Daten übertragen"

   WSh.Cells(10, iSpalte).Select

   Exit Sub

 End If

 Application.ScreenUpdating = False

 With ThisWorkbook.Sheets("Nachweise")

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

'Ermittle alle gelesenen Dokus

   sMA = WSh.Cells(10, "N").Value

   For iZl = 2 To iZeile - 1

    If .Cells(iZl, "A").Value = sMA Then

      For iSpalte = 5 To .UsedRange.Columns.Count Step 2

          If .Cells(iZl, iSpalte).Value = "" Then Exit For

          sGelesene = sGelesene & .Cells(iZl, iSpalte).Value _

              & .Cells(iZl, iSpalte + 1).Value & ","

      Next iSpalte

    End If

   Next iZl

   .Unprotect

'Uli Bezeichnung und Index mit kopieren

   iSpalte = 5

   For iZl = 10 To 100

     If WSh.Cells(iZl, "C").Value = "" Then Exit For

     sCheck = WSh.Cells(iZl, "C").Value & WSh.Cells(iZl, "K").Value

     If InStr(sGelesene, sCheck & ",") = 0 Then

       .Cells(iZeile, iSpalte + 0).Value = WSh.Cells(iZl, "C").Value

       .Cells(iZeile, iSpalte + 1).Value = WSh.Cells(iZl, "K").Value

       iSpalte = iSpalte + 2     'wenn die Item nacheinander gezeigt werden sollen

       bCheck = True

     End If

Rem       iSpalte = iSpalte + 2  'wenn die Item passend untereinanderstehen sollen

   Next iZl

   If bCheck = True Then

'Texte kopieren und löschen

    .Range("A" & iZeile & ":C" & iZeile).Value = WSh.Range("N10:P10").Value

    WSh.Range("N10:P10").ClearContents

'Grafik suchen und kopieren

    On Error Resume Next

    WSh.Shapes.Range(Array(sShapeName)).Copy

'Grafik einfügen

    .Select

    .Paste

'Grafik in Zelle einpassen

    Set AC = .Range("$D$" & iZeile)

    If TypeName(Selection) = "Picture" Then

      With Selection.ShapeRange

         .Name = "Unterschrift"

         .LockAspectRatio = True

         If (.Width / AC.Width) &LT; (.Height / AC.Height) Then

            .Height = AC.Height          'Bild höher als breit

         Else

            .Width = AC.Width

         End If

         .Left = AC.Left + ((AC.Width - .Width) &bsol; 2)

         .Top = AC.Top + ((AC.Height - .Height) &bsol; 2)

      End With

    End If

'Neuen Eintrag verschieben in erste Zeile

   .Rows("2:" & iZeile).Cut Destination:=.Rows("3:" & (iZeile + 1))

   .Rows(iZeile + 1 & ":" & iZeile + 1).Cut Destination:=.Rows("2:2")

'Blatt wieder schützen

   .Range("A1").Select

   .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

  End If

 End With

'Bereich und Bild löschen

 WSh.Select

 If bCheck Then ActiveSheet.Shapes.Range(Array(sShapeName)).Delete

 Application.ScreenUpdating = True

End Sub

Viele Grüße aus Freigericht
Karl-Heinz

Beliebteste Forumthreads (12 Monate)

Makro kopiert, aber der Feinschliff

33
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro kopiert, aber der Feinschliff

33 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

33
Beiträge zum Forumthread

Beiträge zu diesem Forumthread