Office: Probleme mit dem Code

Hallo Zusammen

Ich habe folgenden Code bei mir im VBA drin.

Code:

Private Sub CommandButton1_Click()
Sheets("Auftragskarte").Unprotect pw
    Dim wbTarget As Workbook, wsTarget As Worksheet, wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Auftragskarte")               'Tabelle, die kopiert werden soll
    Set wbTarget = Workbooks.Open("D:\Hartmann\Maschinen-Verwaltung\Aufträge\Auftragsübersicht.xls") 'Mappe, die geöffnet werden soll
    On Error Resume Next
    Set wsTarget = wbTarget.Sheets("Auftrag " & wsSource.Cells(19, 42))
    On Error GoTo 0
    If wsTarget Is Nothing Then
        Set wsTarget = wbTarget.Sheets.Add(after:=wbTarget.Sheets(wbTarget.Sheets.Count))
        wsTarget.Name = "Auftrag " & wsSource.Cells(19, 42)
        wsSource.Cells.Copy
        wsTarget.Cells(1, 1).PasteSpecial xlPasteValues
        wsTarget.Cells(1, 1).PasteSpecial xlPasteAll
        Range("B4").Select
        Application.CutCopyMode = False
        wbTarget.Close SaveChanges:=True
    Else
        MsgBox ("Kann nicht kopiert werden! Tabelle schon vorhanden.")
        wbTarget.Close SaveChanges:=False
    End If
    Unload Me
End Sub

Leider werden die Formel mit kopiert was ja nich sein soll. Es soll ja die Formel durch das Ergeniss ersetzt werden da ich ja nicht immer beide Mappen auf habe.

Wäre schön wenn mir da mal jemad helfen kann.


Gruß Michael

 

Hallo Michael,

ich gehe mal stark davon aus, dass diese Zeile hier das Problem ist:

Code:

        wsTarget.Cells(1, 1).PasteSpecial xlPasteAll

Du kopierst erst die Werte und danach Alles. Und Alles beinhaltet nunmal auch die Formeln. Falls es Dir um die Formate geht, die kannst Du mit

Code:

xlPasteFormats

einfügen.

Gruß
Michael

 

Hallo Michael

Danke für die super schnelle Antwort.

Genau so wollte ich es haben!


Vielen vielen dank

Gruß Michael

 

Eins habe ich noch vergessen

Kannst Du mir verten wie ich das einstellen kann das die Nullwert keine Null haben. habe es zwar so eingestellt aber irgend wie geht das immer nur Blatt für Blatt und wenn dann nach dem kopieren wieder ein neues Blatt dazu kommt habe ich ja wieder die Null drin. Und wie bekomme ich das Bild auch mit kopier das in dem Blatt ist

Danke

Gruß Michael

 

Ähmmm.... Du bist Dir schon drüber im Klaren dass ich Deine Tabelle nicht kenne oder? ;-)

Also wenn Du mit den Nullwerten die Einstellung meinst die im Tabellenblatt die Nullwerte ausblendet dann füge einfach folgenden Code in Dein Makro mit ein:

Code:

ActiveWindow.DisplayZeros = False

Er macht diese Einstellung in dem Tabellenblatt das gerade aktiv ist.

Was hast Du für ein Bild in dem Tabellenblatt? Da würde es schon helfen wenn Du eine Beispieltabelle hochladen würdest.

Gruß
Michael

 

Hallo Michael

Die Mappe wo es hin kopiert werden soll ist leer und hat auch keinen einzigen Code drin nur die Blätter die schon kopiert worden sind. Es gibt auch Zellen die nicht beschrieben sind und dann steht da eine 0 und das möchte ich nicht.

Zu dem Bild

Es wird von Mappe1 eine kopie von einem Tabellenblatt nach MappeB kopiert ohne Code und ohne Formeln.
Es wird durch den folgenden Code ein Bild in Form eines QR-Codes erstellt im Format .png nun möchte ich das dieses Bild mit in die MappeB kopiert wird.

Code:

Private Sub CommandButton1_Click()
    
    TextBox1 = Cells(19, 42)
    
    Dim strTmpFile As String
    Dim strWWWAdr As String
    Dim bDownLoad As Boolean
    Dim img
    Dim strText As String, strPixelsize As String
  
    bDownLoad = True
    Select Case Len(TextBox1.Text)
    Case 0
        MsgBox "Es muss ein Text vorgeben werden", vbCritical, "QR Text"
        bDownLoad = False
    Case 300
        MsgBox "Achtung: Codes über 300 Zeichen können nicht alle Scanner lesen!", vbExclamation, "QR Text"
    End Select
    If Not bDownLoad Then
         TextBox1.Activate
    Else
        Application.StatusBar = "QR-Code wird generiert...(bitte warten)"
        strWWWAdr = "http://api.qrserver.com/v1/create-qr-code/?data=" & _
                    Replace(Replace(TextBox1, " ", "%20"), vbCrLf, "%0A") & _
                    "%0A&size=" & TextBox2 & "x" & TextBox2
        strTmpFile = ThisWorkbook.Path & "\temp.png"     'temporärerer Dateiname
        bDownLoad = DownloadFile(strWWWAdr, strTmpFile)  'png Datei herunterladen
        If bDownLoad = True Then
         'Ev alten QRCode löschen
         For Each img In Me.Pictures
            If img.Name = "myQRCode" Then img.Delete
          Next
         'QRCode einfügen
          With Me.Pictures.Insert(strTmpFile)
              .Name = "myQRCode"
              .Top = Me.Range("AC12").Top
              .Left = Me.Range("AC12").Left
          End With
         'temporäre Datei löschen
          Kill strTmpFile
        Else
         'wenn Download nicht erfolgreich , dann Meldung
          MsgBox "Datei " & strWWWAdr & " konnte nicht heruntergeladen werden!"
        End If
        Application.StatusBar = False
    End If
End Sub

Private Sub TextBox1_Change()
    'Cells(11, 2) = Len(TextBox1) & " Zeichen"
End Sub

Private Sub TextBox2_LostFocus()
    If Val(TextBox2) < 50 Or Val(TextBox2) > 250 Then
        MsgBox "Die Pixelsize muss sich zwischen 50 und 250 px bewegen!", vbExclamation, "QR Grösse"
        TextBox2.Activate
    End If
End Sub

Private Sub Worksheet_Activate()
Sheets("Auftragskarte").Protect Password:=pw, DrawingObjects:=False
    
TextBox1 = Cells(19, 42)

Dim strTmpFile As String
    Dim strWWWAdr As String
    Dim bDownLoad As Boolean
    Dim img
    Dim strText As String, strPixelsize As String
  
    bDownLoad = True
    Select Case Len(TextBox1.Text)
    Case 0
        MsgBox "Es muss ein Text vorgeben werden", vbCritical, "QR Text"
        bDownLoad = False
    Case 300
        MsgBox "Achtung: Codes über 300 Zeichen können nicht alle Scanner lesen!", vbExclamation, "QR Text"
    End Select
    If Not bDownLoad Then
         TextBox1.Activate
    Else
        Application.StatusBar = "QR-Code wird generiert...(bitte warten)"
        strWWWAdr = "http://api.qrserver.com/v1/create-qr-code/?data=" & _
                    Replace(Replace(TextBox1, " ", "%20"), vbCrLf, "%0A") & _
                    "%0A&size=" & TextBox2 & "x" & TextBox2
        strTmpFile = ThisWorkbook.Path & "\temp.png"     'temporärerer Dateiname
        bDownLoad = DownloadFile(strWWWAdr, strTmpFile)  'png Datei herunterladen
        If bDownLoad = True Then
         'Ev alten QRCode löschen
         For Each img In Me.Pictures
            If img.Name = "myQRCode" Then img.Delete
          Next
         'QRCode einfügen
          With Me.Pictures.Insert(strTmpFile)
              .Name = "myQRCode"
              .Top = Me.Range("AC12").Top
              .Left = Me.Range("AC12").Left
          End With
         'temporäre Datei löschen
          Kill strTmpFile
        Else
         'wenn Download nicht erfolgreich , dann Meldung
          MsgBox "Datei " & strWWWAdr & " konnte nicht heruntergeladen werden!"
        End If
        Application.StatusBar = False
    End If
End Sub


Private Sub Worksheet_Deactivate()

TextBox1 = Cells(19, 42)

Ich hoffe Du verstehst nun mein kleines Problem.

Gruß Michael

 

Hallo Michael,

du hast Zellen in denen nichts steht und Excel zeigt eine 0 an? Das würde ich gerne mal in einer Beispielmappe sehen.
Was das Bild anbelangt: Ohne die Excelmappe zu sehen kann ich auch nur ungefähre Anweisungen geben. Ich würde an Deiner Stelle das Bild, kopieren mit

Code:

ActiveSheet.Shapes.Range(Array("Picture 1")).Copy

und in der anderen Mappe einfügen. Der Name des Bildes muss natürlich angepasst werden.

Viele Grüße
Michael

 

Hallo Michael

Die Datei ist leider viel zu groß um sie hier über das Forum hochzuladen. Ich habe die Datei daher auf meinen Server geladen.

Wunder Dich bitte nicht das es soviele Codes und kram gibt aber die Datei ist Teilweise schon in nutzung und ich arbeite noch an der ganzen sache rum. Ist alles noch in Arbeit.

Das Passwort für den Blattschutz ist Passwort nach Problemlösung entfernt.

klick Hier zum Downloaden Link nach Problemlösung entfernt.

Gruß Michael

 

Hallo Michael,

Und wo in der Datei sind jetzt die Nullen? Bzw. wo wird der QR Code erzeugt? Bitte sei so nett und beschreibe doch einfach ein bisschen was. Ich hab ehrlich gesagt keine Zeit mich durch 20 Module zu klicken bis ich die Probleme gefunden habe.

Viele Grüße
Michael

 

Hallo Michael

Sorry hatte es vergessen zu schreiben. Ist ein Chaos in meiner Mappe aber in mom komme ich auch nicht dazu alles mal in Ordnung zu bringen.

Die Tabelle ist ausgeblendet und der Name ist Auftragskarte.
Das ist die Tabelle mit dem Bild und den Nullwerten.

Gruß Michael

 

Hallo Michael,

der Code um den QR Code zu kopieren ist:

Code:

Sheets("Auftragskarte").Shapes.Range(Array("myQRCode")).Select

Um ihn wieder einzufügen musst Du an der Stelle des Makros an der eingefügt werden soll folgenden Code eintragen:

Code:

Range("AC12").Select
ActiveSheet.Paste

Das mit den Nullen kann ich immer noch nicht nachvollziehen.

Gruß
Michael

 

Hallo Michael
Danke schon mal werde es gleich mal testen.

Ich habe in der Auftragskarte Formeln drin. Wenn ich es so kopiere wie es bei Dir ist dann haben ich in der Kopierten Tabelle in der Zelle K11 eine Null stehen da für diese Zelle kein Wert vorhanden ist was auch in den anderen Zellen vorkommen kann. Nun möchte ich aber dort nichts stehen haben.

Ich hoffe Du konntest mich nun verstehen.

Gruß Michael

 

Hallo Michael

Wie und wo muß ich nun das einbauen damit das Bild kopiert wird.

Hier mal der Code zum kopieren.

Code:

Private Sub CommandButton1_Click()
Sheets("Auftragskarte").Unprotect pw
    Dim wbTarget As Workbook, wsTarget As Worksheet, wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Auftragskarte")               'Tabelle, die kopiert werden soll
    Set wbTarget = Workbooks.Open("D:\Hartmann\Maschinen-Verwaltung\Aufträge\Auftragsübersicht.xls") 'Mappe, die geöffnet werden soll
    On Error Resume Next
    Set wsTarget = wbTarget.Sheets("Auftrag " & wsSource.Cells(19, 42))
    On Error GoTo 0
    If wsTarget Is Nothing Then
        Set wsTarget = wbTarget.Sheets.Add(after:=wbTarget.Sheets(wbTarget.Sheets.Count))
        wsTarget.Name = "Auftrag " & wsSource.Cells(19, 42)
        wsSource.Cells.Copy
        wsTarget.Cells(1, 1).PasteSpecial xlPasteValues
        wsTarget.Cells(1, 1).PasteSpecial xlPasteFormats
        Range("B4").Select
        Application.CutCopyMode = False
        wbTarget.Close SaveChanges:=True
    Else
        MsgBox ("Kann nicht kopiert werden! Tabelle schon vorhanden.")
        wbTarget.Close SaveChanges:=False
    End If
    Unload Me
End Sub

Ich habe es versucht aber es kommt immer wieder ein fehler.

Gruß Michael

 

Hallo Michael,

jepp jetzt weiß ich worum es geht. Das war unmissverständlich. Das Problem ist, dass in Deiner Ausgangsdatei die Datei eben nicht leer ist sondern eine 0 drin steht. Du hast lediglich über die Optionen alle Nullen ausblenden lassen. Da diese Option nicht standardmäßig in neuen Arbeitsblättern gesetzt wird siehst Du auch eine Null in der Kopie. Es gibt jetzt 2 Möglichkeiten. Entweder Du sorgst dafür, dass Deine Formeln keine Nullen ausspucken sondern statt dessen ein leeres Feld, oder aber Du setzt in der neuen Datei eben auch die Option auf Nullen nicht anzeigen. Die Option mit Nullen ausblenden habe ich im folgenden Code miteingebaut:

Code:

Private Sub CommandButton1_Click()
Sheets("Auftragskarte").Unprotect pw
    Dim wbTarget As Workbook, wsTarget As Worksheet, wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Auftragskarte")               'Tabelle, die kopiert werden soll
    Set wbTarget = Workbooks.Open("Z:\Auftragsübersicht.xls") 'Mappe, die geöffnet werden soll
    On Error Resume Next
    Set wsTarget = wbTarget.Sheets("Auftrag " & wsSource.Cells(19, 42))
    On Error GoTo 0
    If wsTarget Is Nothing Then
        Set wsTarget = wbTarget.Sheets.Add(after:=wbTarget.Sheets(wbTarget.Sheets.Count))
        wsTarget.Name = "Auftrag " & wsSource.Cells(19, 42)
        wsSource.Cells.Copy
        wsTarget.Cells(1, 1).PasteSpecial xlPasteValues
        wsTarget.Cells(1, 1).PasteSpecial xlPasteFormats
        Range("B4").Select
        Application.CutCopyMode = False
        ActiveWindow.DisplayZeros = False 'Setzt die Option dass Nullen nicht angezeigt werden
        Windows("Maschinen Verwaltung.xls").Activate 'Ruft die Originaldatei auf
        Sheets("Auftragskarte").Shapes.Range(Array("myQRCode")).Select 'Wählt den QR Code aus
        Selection.Copy 'Kopiert den QR Code
        Windows("Auftragsübersicht.xls").Activate 'Zurück in die Auftragsübersicht
        Range("AC12").Select 'Richtige Zelle auswählen
        ActiveSheet.Paste 'einfügen
        wbTarget.Close SaveChanges:=True
    Else
        MsgBox ("Kann nicht kopiert werden! Tabelle schon vorhanden.")
        wbTarget.Close SaveChanges:=False
    End If
    Unload Me
    
End Sub

Achtung eventuell müssen die Dateinamen angepasst werden, je nachdem wie sie bei Dir heißen.

Gruß
Michael

 

Hallo Michael

Vielen Vielen Dank das klappt genauso wie gewollt. Kannst Du mir nur noch sagen wie ich die makierung nach dem Kopieren vom Bild lösen kann in beiden Mappen. Da nach aufruf der Auftragsübersicht das Bild noch Makiert ist. Habe das sogen das es einer versehntlich löscht oder so.

Schön wäre es auch das wenn die Ziel-Datei schon öffen ist das er das öffnen überspringt und es gleich kopiert. Habe ich gerade germekt das mir dann eine Fehlermeldung kommt.

Aber echt der Hammer wie Ihr alle das so könnt. Ich vermute mal das ich einfach zu blöd bin das zu lernen.

Gruß Michael