VbaMakro

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: VbaMakro

01.12.2017 07:54:25

fcs

AW: VbaMakro

02.12.2017 12:19:55

Sepp

'Makro in einem allgemeinen Modul Sub Copy_nach_B() Dim wksQ As Worksheet, wksZ As Worksheet Dim ZeileQ As Long, ZeileZ As Long, ZeileQL As Long If MsgBox("Daten jetzt in neues Blatt kopieren", _ vbQuestion + vbOKCancel, "Daten kopieren") = vbCancel Then Exit Sub Set wksQ = ActiveWorkbook.Worksheets("Sheet A") 'Name ggf anpassen With wksQ 'letzte Zeile mit Inhalt in Spalten D, E oder G ZeileQL = Application.WorksheetFunction.Max(.Cells(.Rows.Count, 4).End(xlUp).Row, _ .Cells(.Rows.Count, 5).End(xlUp).Row, .Cells(.Rows.Count, 7).End(xlUp).Row) For ZeileQ = 2 To ZeileQL 'Prüfbedingungen für kopieren If Not LCase(.Cells(ZeileQ, 7).Value) = "nein" Then If wksZ Is Nothing Then 'neues Tabellenblatt in Arbeitsmake anlegen With ActiveWorkbook Set wksZ = .Worksheets.Add(After:=wksQ) End With With wksZ 'Spalten-Titel ZeileZ = 1 .Cells(ZeileZ, 1) = "Titel 1" .Cells(ZeileZ, 2) = "Titel 2" .Cells(ZeileZ, 3) = "Titel 3" .Range("A2").Select ActiveWindow.FreezePanes = True End With End If ZeileZ = ZeileZ + 1 'nur Werte übertragen wksZ.Cells(ZeileZ, 1) = .Cells(ZeileQ, 4).Value wksZ.Cells(ZeileZ, 2) = .Cells(ZeileQ, 5).Value wksZ.Cells(ZeileZ, 3) = .Cells(ZeileQ, 7).Value 'oder Zellen kopieren .Range(.Cells(ZeileQ, 4), .Cells(ZeileQ, 5)).Copy wksZ.Cells(ZeileZ, 1) .Cells(ZeileQ, 7).Copy wksZ.Cells(ZeileZ, 3) End If Next End With If ZeileZ = 0 Then MsgBox "keine Daten zum kopieren gefunden", _ vbInformation + vbOKOnly, "Daten kopieren" End If End Sub

Hallo Flow,
ein Anderer Ansatz.
Beispieldatei: https://www.herber.de/bbs/user/118056.xlsm (Datei muss gespeichert sein!)
Code:

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub grabData()
Dim objADO As Object, objSheet As Object, objField As Object
Dim strColums As String, strWhere As String
Dim lngIndex As Long

Const cstrDataSheetName As String = "Sheet A" 'Tabelle mit den Daten
Const cstrNewSheetName As String = "Sheet B"  'Ausgabetabelle

On Error GoTo ERRORHANDLER

With Sheets(cstrDataSheetName)
  strColums = "[" & .Range("D1").Text & "], [" & .Range("E1").Text & "], [" & .Range("G1").Text & "]"
  strWhere = "WHERE " & .Range("G1").Text & "<>'nein' OR " & .Range("G1").Text & " IS NULL"
  Set objADO = ExcelTable(ThisWorkbook.FullName, cstrDataSheetName, _
    .Range("A1").CurrentRegion.Address(0, 0), strColums, strWhere)
End With

If Not objADO Is Nothing Then
  If SheetExist(cstrNewSheetName) Then
    Set objSheet = Sheets(cstrNewSheetName)
    objSheet.UsedRange.Clear
  Else
    Set objSheet = ThisWorkbook.Worksheets.Add(After:=Sheets("Sheet A"))
    objSheet.Name = cstrNewSheetName
  End If
  With objSheet
    For Each objField In objADO.Fields
      lngIndex = lngIndex + 1
      .Cells(1, lngIndex) = objField.Name
    Next
    .Cells(2, 1).CopyFromRecordset objADO
    .Columns.AutoFit
  End With
  objADO.Close
Else
  MsgBox "Keine Daten gefunden!"
End If

ERRORHANDLER:

If Err.Number <> 0 Then
  MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "grabData" & vbLf & _
    "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
    IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
  Err.Clear
End If

Set objADO = Nothing
Set objSheet = Nothing
End Sub

Private Function ExcelTable(ByVal Path As String, ByVal Table As String, ByVal SourceRange As _
  String, Optional SelectColumns As String = "*", Optional WhereString As String = "") As Object
Dim SQL As String
Dim Con As String

On Error GoTo ERRORHANDLER
If ((GetAttr(Path) And vbDirectory) <> vbDirectory) Then
  SQL = "SELECT " & SelectColumns & " FROM [" & Table & "$" & SourceRange & "] " & WhereString
  If Mid(Path, InStrRev(Path, ".") + 1) = "xls" Then
    Con = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & "Data Source=" & _
      Path & ";"
  ElseIf Mid(Path, InStrRev(Path, ".") + 1) Like "xls?" Then
    Con = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" & _
      "Data Source=" & Path & ";"
  Else
    GoTo ERRORHANDLER
  End If
  Set ExcelTable = CreateObject("ADODB.Recordset")
  ExcelTable.Open SQL, Con, 3, 1
  Exit Function
End If
ERRORHANDLER:
Set ExcelTable = Nothing
End Function

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook, Optional ByVal byCodeName As Boolean = False) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
  If byCodeName Then
    If LCase(wks.CodeName) = LCase(sheetName) Then SheetExist = True: Exit Function
  Else
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  End If
Next
ERRORHANDLER:
SheetExist = False
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

VbaMakro

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread