Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1536to1540
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Kopieren und Summe bilden

Kopieren und Summe bilden
29.01.2017 14:45:27
Markus
Hallo Forum,
ich habe zwei Anliegen an euch:
Mit dem VBA-Code
Sub Copy_x()
Dim i As Long, suchCol As Long
Dim strSearch As Long
Dim srcWks As Worksheet, tarWks As Worksheet
'Tabellennamen anpassen
'srcWks wo gesucht werden soll
Set srcWks = Worksheets("Tabelle1")
'tarWks wo hinkopiert werden soll
Set tarWks = Worksheets("Tabelle2")
suchCol = 5
strSearch = 500
With srcWks
For i = 1 To .Cells(Rows.Count, suchCol).End(xlUp).Row
If .Cells(i, suchCol).Value > strSearch Then
Rows(i).Copy Destination:=tarWks.Cells(tarWks.Cells(Rows.Count, 1).End(xlUp). _
Row + 1, 1)
End If
Next i
End With
End Sub
kann ich mir alle > 500 Umsatz Modelle in ein anders Tabellenblatt kopieren.
Beispielmappe : https://www.herber.de/bbs/user/110980.xlsm
a) ich möchte aus Tabelle 1 nur die Spalten Land(A) - Modell(B) und Umsatz(E) in die Tabelle 2 übertragen
b) eine Summe der Umsätze bilden (oben - siehe Beispieldatei)
Vielen Dank für eure Mühe

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kopieren und Summe bilden
29.01.2017 16:53:11
Crazy
Hallo
das habe ich so getestet
auszuführen von Tabelle1
Sub Copy_x()
Dim i As Long, suchCol As Long
Dim lngSearch As Long
Dim lngZiel As Long
Dim srcWks As Worksheet, tarWks As Worksheet
'Tabellennamen anpassen
'srcWks wo gesucht werden soll
Set srcWks = Worksheets("Tabelle1")
'tarWks wo hinkopiert werden soll
Set tarWks = Worksheets("Tabelle2")
suchCol = 5
lngSearch = 500
With tarWks
lngZiel = .Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 1 To Cells(Rows.Count, suchCol).End(xlUp).Row
If Cells(i, suchCol).Value > lngSearch Then
.Cells(lngZiel, 1) = Cells(i, 1)
.Cells(lngZiel, 2) = Cells(i, 2)
.Cells(lngZiel, 3) = Cells(i, 5)
lngZiel = lngZiel + 1
End If
Next i
End With
End Sub
MfG Tom
Anzeige
AW: Kopieren und Summe bilden
29.01.2017 17:01:19
Markus
Hallo Tom,
funktioniert super - danke dir!
Eine Bitte noch: Ich will in Tabelle2 noch eine Summe der Umsätze bilden (siehe Beispielmappe, gelb markiert). Wie kann ich es ins Makro einbauen?
Danke
AW: Kopieren und Summe bilden
29.01.2017 17:33:03
Michael
Hi,
hat sich mit Toms Antwort überschnitten, aber wenn ich mir die Arbeit schon gemacht habe:
Sub aufruf()
MsgBox copyNeu(5, 500, "Tabelle1", "Tabelle2")
End Sub
Function copyNeu(sp&, abUms&, von$, nach$) As String
Dim aIn, aOut ' das werden sogenannte Arrays
Dim zI&, zO&, zMax&
' & = as long; zI: Zeile "input", zO: Zeile "output", max. Zeile
Dim weg As Boolean
weg = MsgBox(nach & " überschreiben?", vbYesNo) = vbYes
On Error GoTo fehler
With Sheets(von)
zMax = .Cells(.Rows.Count, sp).End(xlUp).Row
If zMax = 1 Then copyNeu = "keine Daten": Exit Function
aIn = .Range("A2:E" & zMax) ' ohne Überschrift
End With
With Sheets(nach)
If weg Then
.Range("A3:C" & .Rows.Count).ClearContents
zO = 2
Else
zO = .Cells(.Rows.Count, 1).End(xlUp).Row
If zO  abUms Then
zMax = zMax + 1
aOut(zMax, 1) = aIn(zI, 1)
aOut(zMax, 2) = aIn(zI, 2)
aOut(zMax, 3) = aIn(zI, 5)
End If
Next
With Sheets(nach)
.Range("A" & zO + 1).Resize(zMax, 3) = aOut
.Range("C2").FormulaLocal = "=summe(C3:C" & zO + zMax & ")"
End With
fehler:
If Err.Number  0 Then
copyNeu = Err.Description
Else
copyNeu = "ok"
End If
End Function
Gruß,
Michael
Anzeige
AW: Kopieren und Summe bilden
29.01.2017 17:40:38
Markus
Hallo Michael,
super, danke dir für deine Mühe :)
gern geschehen & Gruß zurück owT
29.01.2017 17:49:28
Michael
AW: Kopieren und Summe bilden
29.01.2017 22:09:50
Markus
Hi Onur,
funktioniert auch - besten Dank dir!

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige