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