Office: mehrere getrennte Spalten markieren

thomme1 · 13. September 2010

Besten Dank Ingolf

Habs getestet und funktioniert bis auf Tabelle Div.
Da schreibt er alle Bestellpositionsnummern (Formel in Ausgangstabelle) rein auch wenn Spalten F oder J leer sind.

Wenn das behoben ist wird vielleicht auch der Vorgang schneller.

Bevor der Datenexport erfolgt (Makro Kopieren_in_Rechnungsübersicht) starte ich Makro Datenzeilensortieren welches mir alle Bestellungen filtert, markiert. Ist es möglich von da aus zu kopieren, dann sind die überflüssigen Positionsnummern auch weg.

Danke und besten Grüsse

IngGi · 13. September 2010

Hallo Thomas,

hier noch die Einschränkung für das Tabellenblatt Div:

Sub Kopieren_in_Rechnungsübersicht()
' Tastenkombination: Strg+r
'Beispiel: C:\BBAG Abrechnung\Rechnungsübersicht.xlt (richtig!) öffnen
Application.ScreenUpdating = False
Dim bExists As Boolean
Dim wb As Workbook
Dim wbVorlage As Workbook
Dim wbDaten As Workbook
Dim wsVorlage As Worksheet
Dim wsDaten As Worksheet

Set wbDaten = ThisWorkbook
Set wsDaten = wbDaten.ActiveSheet

' Prüfen ob Datei bereits geöffnet ist
bExists = False
With Application
For Each wb In .Workbooks
If UCase$(wb.Name) = "RECHNUNGSÜBERSICHT.XLT" Then
' Jetzt aktivieren
Set wbVorlage = Workbooks(wb.Name)
bExists = True
Exit For
End If
Next
End With

' Mappe neu laden!
If Not bExists Then
On Error Resume Next
Set wbVorlage = Workbooks.Open(Filename:="C:\MOF\Rechnungsübersicht.xlt", ReadOnly:=False)
On Error GoTo 0
End If

Dim rng As Range

For Each rng In wsDaten.Range("CH16:CH" & _
wsDaten.Cells(Rows.Count, "CH").End(xlUp).Row)

Set wsVorlage = Nothing
If rng = "k" Then
Set wsVorlage = wbVorlage.Sheets("Konfigurator")
ElseIf rng = "s" Then
Set wsVorlage = wbVorlage.Sheets("Standard")
ElseIf rng = "d" Then
Set wsVorlage = wbVorlage.Sheets("Div")
End If

If Not wsVorlage Is Nothing Then
rng.Offset(0, -76).Copy 'Spalte J
wsVorlage.Range("C" & wsVorlage.Cells(Rows.Count, "C") _
.End(xlUp).Row).Offset(1, -2).PasteSpecial Paste:=xlPasteValues

rng.Offset(0, 1).Copy 'Spalte CI
wsVorlage.Range("C" & wsVorlage.Cells(Rows.Count, "C") _
.End(xlUp).Row).Offset(1, -1).PasteSpecial Paste:=xlPasteValues

rng.Offset(0, -80).Copy 'Spalte F
wsVorlage.Range("C" & wsVorlage.Cells(Rows.Count, "C") _
.End(xlUp).Row).Offset(1, 1).PasteSpecial Paste:=xlPasteValues

rng.Offset(0, -21).Copy 'Spalte BM
wsVorlage.Range("C" & wsVorlage.Cells(Rows.Count, "C") _
.End(xlUp).Row).Offset(1, 2).PasteSpecial Paste:=xlPasteValues

rng.Offset(0, -71).Copy 'Spalte O
wsVorlage.Range("C" & wsVorlage.Cells(Rows.Count, "C") _
.End(xlUp).Row).Offset(1, 3).PasteSpecial Paste:=xlPasteValues

rng.Offset(0, -22).Copy 'Spalte BL
wsVorlage.Range("C" & wsVorlage.Cells(Rows.Count, "C") _
.End(xlUp).Row).Offset(1, 4).PasteSpecial Paste:=xlPasteValues

rng.Offset(0, 0).Copy 'Spalte CH
wsVorlage.Range("C" & wsVorlage.Cells(Rows.Count, "C") _
.End(xlUp).Row).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If

Next 'rng

Set wsVorlage = wbVorlage.Sheets("Bestellwert Bestellnummer")

wsDaten.Range("J16:J" & wsDaten.Cells(Rows.Count, "J").End(xlUp).Row).Copy
wsVorlage.Range("A2").PasteSpecial Paste:=xlPasteValues
wsDaten.Range("CI16:CI" & wsDaten.Cells(Rows.Count, "CI").End(xlUp).Row).Copy
wsVorlage.Range("B2").PasteSpecial Paste:=xlPasteValues
wsDaten.Range("CH16:CH" & wsDaten.Cells(Rows.Count, "CH").End(xlUp).Row).Copy
wsVorlage.Range("C2").PasteSpecial Paste:=xlPasteValues
wsDaten.Range("F16:F" & wsDaten.Cells(Rows.Count, "F").End(xlUp).Row).Copy
wsVorlage.Range("D2").PasteSpecial Paste:=xlPasteValues
wsDaten.Range("BM16:BM" & wsDaten.Cells(Rows.Count, "BM").End(xlUp).Row).Copy
wsVorlage.Range("E2").PasteSpecial Paste:=xlPasteValues
wsDaten.Range("O16:O" & wsDaten.Cells(Rows.Count, "O").End(xlUp).Row).Copy
wsVorlage.Range("F2").PasteSpecial Paste:=xlPasteValues
wsDaten.Range("BL16:BL" & wsDaten.Cells(Rows.Count, "BL").End(xlUp).Row).Copy
wsVorlage.Range("G2").PasteSpecial Paste:=xlPasteValues

Set wsVorlage = Nothing
Set wbVorlage = Nothing
Set wsDaten = Nothing
Set wbDaten = Nothing

Application.ScreenUpdating = True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

VBA/HTML - CodeConverter für Excelforen
AddIn für Excel XP+2003 - komplett in VBA geschrieben von IngGi
Anbindung an VBE-Kontextmenü geklaut ;-) bei:
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

thomme1 · 13. September 2010

Hoi Ingolf

Besten Dank für Deine Hilfe.
Werde morgen das ganze nochmals testen und dann hoffentlich zu einem Abschluss kommen,
Einen schönen ruhigen Abend wunsche ich Dir.

thomme1 · 14. September 2010

Hallo Ingolf

Habe Deinen Code getestet an einer scharfen Datei und es läuft alles zu meiner besten Zufriedenheit.

Möchte Dir für Deine Geduld und Hilfe nochmals ganz herzlichst danken.

Gruss

Thomas

Office: mehrere getrennte Spalten markieren

mehrere getrennte Spalten markieren

mehrere getrennte Spalten markieren

mehrere getrennte Spalten markieren

mehrere getrennte Spalten markieren - Similar Threads - getrennte Spalten markieren

Zelleninhalte in andere Zelle mit Komma getrennt

Textdatei mit Semikolon getrennten Werten in Verteilerliste in Outlook exportieren

Spalteninhalte vergleichen Werte durch Leerzeichen getrennt

Index Vergleich Zahlen durch Komma getrennt werden erkannt einzelne ohne Komma aber nicht

Werte von getrennten und verbundenen Zellen vereinen

Getrennte Bereiche in PDF auf einer Seite

Mehrere Werte getrennt (,) in eine Zelle eintragen