Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1336to1340
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

Excel-Makro: Zellen kopieren

Excel-Makro: Zellen kopieren
31.10.2013 14:11:27
Thomas
Hallo,
ich bin absoluter excel und vor allem VBA Neuling.
Ich habe hier ein Problem und hoffe auf Lösungsvorschläge.
Ich habe eine Tabelle die unterschiedlich viele Spalten und Zeilen hat. Je nach Eingabe.
Durch "Knopfdruck" sollen nun a) alle Spalten einer Reihe (insofern die Spalte beschrieben ist) in einer zusammengefasst werden. Das gilt für alle Zeilen der Tabelle. Die Zusammengefassten Zeilen sollen dabei in ein neues sheet kopiert werden welches den Namen der 1. Spalte und Zeile der Ursprungstabelle erhalten soll.
Bsp:
Tabelle1:
Serie1 Test1 Test2 Test3
Serie1 Test4 Test5 Test6 Test7
Neues Blatt soll somit Serie1 heissen.
Neue Tabelle soll so aussehen
Serie1_Test1_Test2_Test3
Serie1_Test4_Test5_Test6_Test7
Hoffe auf Rat.
Die Ursprungstabelle wird letztendlich als Eingabemaske dienen. Je nachdem sind das 14-20 Einträge pro Spalte, und es können bis zu 200 Reihen sein.
Viele Grüße,
Thomas

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel-Makro: Zellen kopieren
01.11.2013 13:48:06
fcs
Hallo Thomas,
nachfolgend ein entsprechedes Makro inklusive Prüffunktionen für Blattname.
Beachte, das der Blattname max. 31 Zeichen lang sein darf
mfg
Franz
Sub Eingabenverarbeiten()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim Zeile_Q As Long, Spalte_Q As Long, Zeile_Z As Long
Dim strErgebnis As String, strBlatt As String
If MsgBox("Eingaben jetzt aufbereiten und in Tabellenblätter eintragen?", _
vbQuestion + vbOKCancel, "Eingaben auswerten") = vbCancel Then Exit Sub
Set wksQuelle = Worksheets("Tabelle1")
Application.ScreenUpdating = False
With wksQuelle
'Zieltabele setzen
strBlatt = fncCheckSheetName(.Cells(1, 1).Text) 'Name in Zelle A1 auslesen
If fncCheckSheet(strBlatt) = False Then
'neues Blatt hinzufügen
With ActiveWorkbook
Set wksZiel = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
wksZiel.Name = strBlatt
Zeile_Z = 1 '1. Zeile, in die ein Ergebis eingetragen werden soll
End With
Else
Set wksZiel = Worksheets(strBlatt)
With wksZiel
'nächste freie Zeile in Spalte A
Zeile_Z = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
End If
For Zeile_Q = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(Zeile_Q, 1)  "" Then
'Ergebnistext aus Werten in Zeile zusammensetzen
strErgebnis = .Cells(Zeile_Q, 1).Text
For Spalte_Q = 2 To .Cells(Zeile_Q, .Columns.Count).End(xlToLeft).Column
If .Cells(Zeile_Q, Spalte_Q)  "" Then
strErgebnis = strErgebnis & "_" & .Cells(Zeile_Q, Spalte_Q).Text
End If
Next Spalte_Q
'Ergebnis in Zieltabelle eintragen
wksZiel.Cells(Zeile_Z, 1) = strErgebnis
Zeile_Z = Zeile_Z + 1
End If
Next Zeile_Q
End With
Application.ScreenUpdating = False
Set wksQuelle = Nothing: Set wksZiel = Nothing
End Sub
Function fncCheckSheetName(strBlatt As String)
'unzulässige Sonderzeichen im vorgesehenen Namen durch "_" ersetzen, _
Länge ggf. auf 31 Zeichen reduzieren
Dim intPos As Integer, strErgebnis As String
fncCheckSheetName = Left(strBlatt, 31)
For intPos = 1 To Len(fncCheckSheetName)
Select Case Mid(fncCheckSheetName, intPos, 1)
Case ":", "/", "\", "*", "?", "[", "]"
strErgebnis = strErgebnis & "_"
Case Else
strErgebnis = strErgebnis & Mid(fncCheckSheetName, intPos, 1)
End Select
Next
fncCheckSheetName = strErgebnis
End Function
Function fncCheckSheet(strBlatt, Optional wkb As Workbook) As Boolean
'Prüft, ob ein Blatt mit dem Namen schon in der Arbeitsmappe vorhanden ist
Dim objSheet As Object
On Error GoTo Beenden
If wkb Is Nothing Then Set wkb = ActiveWorkbook
Set objSheet = wkb.Sheets(strBlatt)
fncCheckSheet = True
Exit Function
Beenden:
End Function

Anzeige
AW: Excel-Makro: Zellen kopieren
05.11.2013 20:40:56
Thomas
Danke für die schnelle Antwort!
Funktioniert wunderbar!!
Viele Grüße,
Thomas

AW: Frage ist beantwortet
06.11.2013 12:58:58
Der
...

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige