Kopieren von bestimmten Zeilen aus excel-basierend auf einer bestimmten Zelle der Wert

Anstatt der beliebten " Was haben Sie versucht?' zwingen Sie zu schreiben
code ohne einen plan, überlegen Sie (und Fragen) das know-how/wissen/Methoden/tools
notwendig für die Auswahl bestimmter Zeilen der Blätter/Tabellen in neue Blätter/Tabellen.

"wählen" bedeutet SQL und während Excel ist kein Datenbank-mangement-system können Sie
verwenden Sie ein .XLS als Datenbank: mit ein wenig Hilfe von ADO.

Also mein plan wäre:

(1) Öffnen Sie ein ADODB.Verbindung zu Ihrer Quelle .XLS

(2) Holen Sie sich eine Liste aller Blätter/Tabellen zu verarbeiten

(3) (2) zum erzeugen einer Anweisung wie

SELECT [A] FROM [Tbl1] UNION SELECT [A] FROM [Tbl2] UNION SELECT [A] FROM [Tbl3] ORDER BY [A]

(4) Ausführen, (3) und Schleife über das resultset

(5) Für Jede Module1 ... ModuleLast

(5a) Zu erstellen, die neues Blatt/Tabelle für das Modul M am Ziel .XLS, ausführen einer Anweisung, wie

SELECT * INTO [TblModuleM]  IN "path\to\your\dst.xls" "Excel 8.0;" FROM [Tbl1] WHERE [A] = 'ModuleM'

(5b) Für Jede Tbl2 ... TblLast fügen Sie den ModuleM Zeilen mit Aussagen wie

INSERT INTO [TblModuleM]  IN "path\to\your\dst.xls" "Excel 8.0;" SELECT * FROM [TblT] WHERE [A] = 'ModuleM'

Demo-code, um Ihnen etwas Vertrauen in den plan und einige Stichworte zum nachschlagen:

  Const csSFSpec   = "..\data\14515369\src.xls"
  Const csDFSpec   = "..\data\14515369\dst.xls"
  Const csTables   = "[Tbl1] [Tbl2] [Tbl3]"

  Dim aTblNs  : aTblNs   = Split(csTables)
  Dim oFS     : Set oFS = CreateObject("Scripting.FileSystemObject")
  Dim sSFSpec : sSFSpec = oFS.GetAbsolutePathName(csSFSpec)
  Dim sDFSpec : sDFSpec = oFS.GetAbsolutePathName(csDFSpec)
  If oFS.FileExists(sDFSpec) Then oFS.DeleteFile sDFSpec

  Dim oDbS    : Set oDbS = CreateObJect("ADODB.Connection")
  Dim sCS     : sCS      = Join(Array( _
    "Provider=Microsoft.Jet.OLEDB.4.0", "Data Source=" & sSFSpec, _
    "Extended Properties=""Excel 8.0;HDR=True;IMEX=0;Readonly=False""" _
  ),";")
  WScript.Echo "Connectionstring:"
  WScript.Echo sCS
  oDbS.Open sCS
  Dim sInExt  : sInExt   = " IN """ & sDFSpec & """ ""Excel 8.0;"""

  Dim sSelI : sSelI = "SELECT * INTO [Tbl@Mod] " & sInExt & " FROM @Tbl WHERE [A] = '@Mod'"
  Dim sInsI : sInsI = "INSERT INTO [Tbl@Mod] " & sInExt & " SELECT * FROM @Tbl WHERE [A] = '@Mod'"
  WScript.Echo sSelI
  WScript.Echo sInsI

  Dim sMods : sMods = "SELECT [A] FROM " & aTblNs(0)
  Dim i
  For i = 1 TO UBound(aTblNs)
      sMods = sMods & " UNION SELECT [A] FROM " & aTblNs(i)
  Next
  sMods = sMods & " ORDER BY [A]"
  WScript.Echo sMods

  Dim oRS  : Set oRS = oDbS.Execute(sMods)
  Dim sSQL
  Do Until oRS.EOF
     WScript.Echo "Processing", oRS("A"), "..."
     sSQL = Replace(Replace(sSelI, "@Mod", oRS("A")), "@Tbl", aTblNs(0))
     WScript.Echo "Create & fill new table for", oRS("A")
     WScript.Echo sSQL
     oDbS.Execute sSQL
     For i = 1 To UBound(aTblNs)
         sSQL = Replace(Replace(sInsI, "@Mod", oRS("A")), "@Tbl", aTblNs(i))
         WScript.Echo "Appending for", oRS("A"), "from", aTblNs(i)
         WScript.Echo sSQL
         oDbS.Execute sSQL
     Next
     oRS.MoveNext
  Loop
  oRS.Close
  oDbS.Close

Ausgabe:

Connectionstring:
Provider=Microsoft.Jet.OLEDB.4.0;Data Source=somewheresrc.xls;Extended
 Properties="Excel 8.0;HDR=True;IMEX=0;Readonly=False"
SELECT * INTO [Tbl@Mod]  IN "somewheredst.xls" "Excel 8.0;" FROM @Tbl
WHERE [A] = '@Mod'
INSERT INTO [Tbl@Mod]  IN "somewheredst.xls" "Excel 8.0;" SELECT * FRO
M @Tbl WHERE [A] = '@Mod'
SELECT [A] FROM [Tbl1] UNION SELECT [A] FROM [Tbl2] UNION SELECT [A] FROM [Tbl3] ORDER BY [A]
Processing Module1 ...
Create & fill new table for Module1
SELECT * INTO [TblModule1]  IN "somewheredst.xls" "Excel 8.0;" FROM [T
bl1] WHERE [A] = 'Module1'
Appending for Module1 from [Tbl2]
INSERT INTO [TblModule1]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl2] WHERE [A] = 'Module1'
Appending for Module1 from [Tbl3]
INSERT INTO [TblModule1]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl3] WHERE [A] = 'Module1'
Processing Module2 ...
Create & fill new table for Module2
SELECT * INTO [TblModule2]  IN "somewheredst.xls" "Excel 8.0;" FROM [T
bl1] WHERE [A] = 'Module2'
Appending for Module2 from [Tbl2]
INSERT INTO [TblModule2]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl2] WHERE [A] = 'Module2'
Appending for Module2 from [Tbl3]
INSERT INTO [TblModule2]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl3] WHERE [A] = 'Module2'
Processing Module3 ...
Create & fill new table for Module3
SELECT * INTO [TblModule3]  IN "somewheredst.xls" "Excel 8.0;" FROM [T
bl1] WHERE [A] = 'Module3'
Appending for Module3 from [Tbl2]
INSERT INTO [TblModule3]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl2] WHERE [A] = 'Module3'
Appending for Module3 from [Tbl3]
INSERT INTO [TblModule3]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl3] WHERE [A] = 'Module3'
Processing Module4 ...
Create & fill new table for Module4
SELECT * INTO [TblModule4]  IN "somewheredst.xls" "Excel 8.0;" FROM [T
bl1] WHERE [A] = 'Module4'
Appending for Module4 from [Tbl2]
INSERT INTO [TblModule4]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl2] WHERE [A] = 'Module4'
Appending for Module4 from [Tbl3]
INSERT INTO [TblModule4]  IN "somewheredst.xls" "Excel 8.0;" SELECT *
FROM [Tbl3] WHERE [A] = 'Module4'

InformationsquelleAutor Ekkehard.Horner

Ich gab es einen weiteren Ansatz, abgesehen von SQL und Arten (bereits vorher).

Getestet habe ich diesen code und es funktioniert.

Die Allgemeine Idee hinter diesem code:

1. Klasse Modul "clsSheet" enthält alle Informationen, die pro Blatt, dh. Spaltenüberschriften A, B, C, aber auch der Bereich, der das array, in dem diese Palette wird geladen und die maximale row /col.
2. Diese selbst erstellten Daten-Objekte geladen sind, in eine Sammlung, nach dem der nächste Teil der code ausgeführt wird, werden alle Codes im Speicher (schnell).
3. Ein Wörterbuch erstellt und enthalten die in der "Modul-name" (dh. module1,2,3 etc...) als Schlüssel, und ein clsModule-Objekt als Wert. Wenn eine Taste (also Modul-name) noch nicht existiert, wird ein neuer Eintrag Hinzugefügt werden.
4. Die clsModule Klasse hält die Informationen auf jeder modulename, dh. die Spalten A, B und C Informationen. Die Informationen werden in form von arrays.
5. Wenn alle Daten in das Wörterbuch, es ist nur eine Frage der übersetzung das Wörterbuch-Inhalt wieder in eine form bevorzugt wird. In diesem Fall, ich entschied mich zu geben, zu jedem Blatt den Namen der dictionary-keys und laden Sie die Daten auf Ihren entsprechenden Blättern.

Dieser code enthält:

• Dynamisch findet der Header mit Namen "A", "B" und "C", die reduziert das Risiko für Fehler;
• Schnelle Ausführung;
• Erstellt eine neue Arbeitsmappe und schreibt die Werte für jedes "Modul" auf ein anderes Blatt.
• Diese Klassen sind wiederverwendbar in anderen Situationen mit minimum änderung erforderlich.

Der große Vorteil dieses Ansatzes ist die Flexibilität. Da laden Sie alle Daten in einen Rahmen, Sie können praktisch beliebige Aktionen ausführen danach durch festlegen der Klassen und den Aufruf Ihrer Eigenschaften.

Sub GetModules()


Dim cSheet                      As clsSheet
Dim cModule                     As clsModule
Dim oSheet                      As Excel.Worksheet
Dim oColl_Sheets                As Collection
Dim oDict                       As Object
Dim vTemp_Array_A               As Variant
Dim vTemp_Array_B               As Variant
Dim vTemp_Array_C               As Variant

Dim lCol_A                      As Long
Dim lCol_B                      As Long
Dim lCol_C                      As Long
Dim lMax_Row                    As Long
Dim lMax_Col                    As Long
Dim oRange                      As Range
Dim oRange_A                    As Range
Dim oRange_B                    As Range
Dim oRange_C                    As Range
Dim vArray                      As Variant

Dim lCnt                        As Long
Dim lCnt_Modules                As Long

Dim oBook                       As Excel.Workbook
Dim oSheet_Results              As Excel.Worksheet


Set oColl_Sheets = New Collection
Set oDict = CreateObject("Scripting.Dictionary")

'Get number of columns, rows and headers A, B, C dynamically
'This is useful in case columns are inserted
For Each oSheet In ThisWorkbook.Sheets

    Set cSheet = New clsSheet
    Set cSheet = cSheet.get_Sheet_Data(cSheet, oSheet)

    oColl_Sheets.Add cSheet

Next oSheet

'At this point, your entire sheet data structure is already contained in the collection oColl_Sheets

Set cSheet = Nothing

'Loop through the sheet objects and retrieve the values into modules
For Each cSheet In oColl_Sheets

    'Now you load back all data from the sheet and perform loops in memory through the arrays
    lCol_A = cSheet.fA_Col
    lCol_B = cSheet.fB_Col
    lCol_C = cSheet.fC_Col
    lMax_Row = cSheet.fMax_Row
    lMax_Col = cSheet.fMax_Col
    Set oRange = cSheet.fRange
    vArray = cSheet.fArray

    For lCnt = 1 To lMax_Row - 1

        'Check if the module already exists
        If Not oDict.Exists(vArray(1 + lCnt, 1)) Then  '+1 due to header
            lCnt_Modules = lCnt_Modules + 1
            Set cModule = New clsModule

            'Add to dictionary when new module (thus key) is new
            Set cModule = cModule.Add_To_Array_A(cModule, lCol_A, vArray(1 + lCnt, lCol_A), True)
            Set cModule = cModule.Add_To_Array_B(cModule, lCol_B, vArray(1 + lCnt, lCol_B), True)
            Set cModule = cModule.Add_To_Array_C(cModule, lCol_C, vArray(1 + lCnt, lCol_C), True)

            oDict.Add vArray(1 + lCnt, 1), cModule

        Else

            Set cModule = oDict(vArray(1 + lCnt, 1))

            'Replace when module (thus key) already exists
            Set cModule = cModule.Add_To_Array_A(cModule, lCol_A, vArray(1 + lCnt, lCol_A), False)
            Set cModule = cModule.Add_To_Array_B(cModule, lCol_A, vArray(1 + lCnt, lCol_B), False)
            Set cModule = cModule.Add_To_Array_C(cModule, lCol_A, vArray(1 + lCnt, lCol_C), False)

            Set oDict(vArray(1 + lCnt, 1)) = cModule

        End If

    Next lCnt

Next cSheet

'Now you have all the data available in your dictionary: per module (key), there is an array with the data you need.
'The only thing you have to do is open a new workbook and paste the data there.
'Below an example how you can paste the results per worksheet

Set oBook = Workbooks.Add
Set oSheet_Results = oBook.Sheets(1)

lCnt = 0
For lCnt = 0 To oDict.Count - 1

    'Fill in values from dictionary
    oBook.Sheets.Add().Name = oDict.Keys()(lCnt)
    ReDim vTemp_Array_A(1 To UBound(oDict.Items()(lCnt).fA_Arr))
    ReDim vTemp_Array_B(1 To UBound(oDict.Items()(lCnt).fB_Arr))
    ReDim vTemp_Array_C(1 To UBound(oDict.Items()(lCnt).fC_Arr))
    oBook.Sheets(oDict.Keys()(lCnt)).Range("A1").Value = "A"
    oBook.Sheets(oDict.Keys()(lCnt)).Range("B1").Value = "B"
    oBook.Sheets(oDict.Keys()(lCnt)).Range("C1").Value = "C"

    vTemp_Array_A = oDict.Items()(lCnt).fA_Arr
    vTemp_Array_B = oDict.Items()(lCnt).fB_Arr
    vTemp_Array_C = oDict.Items()(lCnt).fC_Arr
    Set oRange_A = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 1), Cells(1 + UBound(vTemp_Array_A), 1))
    Set oRange_B = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 2), Cells(1 + UBound(vTemp_Array_B), 2))
    Set oRange_C = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 3), Cells(1 + UBound(vTemp_Array_C), 3))
    oRange_A = Application.Transpose(vTemp_Array_A)
    oRange_B = Application.Transpose(vTemp_Array_B)
    oRange_C = Application.Transpose(vTemp_Array_C)

Next lCnt

Set oColl_Sheets = Nothing
Set oRange = Nothing
Set oDict = Nothing

End Sub

Klassenmodul namens "clsModule"

Option Explicit

Private pModule_Nr              As Long
Private pA_Arr                  As Variant
Private pB_Arr                  As Variant
Private pC_Arr                  As Variant

Public Function Add_To_Array_A(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule

Dim vArray As Variant

vArray = cModule.fA_Arr

If bNew Then
    ReDim vArray(1 To 1)
    vArray(1) = vValue
Else
    ReDim Preserve vArray(1 To UBound(vArray) + 1)
    vArray(UBound(vArray)) = vValue
End If

cModule.fA_Arr = vArray

Set Add_To_Array_A = cModule

End Function

Public Function Add_To_Array_B(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule

Dim vArray As Variant

vArray = cModule.fB_Arr

If bNew Then
    ReDim vArray(1 To 1)
    vArray(1) = vValue
Else
    ReDim Preserve vArray(1 To UBound(vArray) + 1)
    vArray(UBound(vArray)) = vValue
End If

cModule.fB_Arr = vArray

Set Add_To_Array_B = cModule

End Function

Public Function Add_To_Array_C(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule

Dim vArray As Variant

vArray = cModule.fC_Arr

If bNew Then
    ReDim vArray(1 To 1)
    vArray(1) = vValue
Else
    ReDim Preserve vArray(1 To UBound(vArray) + 1)
    vArray(UBound(vArray)) = vValue
End If

cModule.fC_Arr = vArray

Set Add_To_Array_C = cModule

End Function


Property Get fModule_Nr() As Long
    fModule_Nr = pModule_Nr
End Property

Property Let fModule_Nr(lModule_Nr As Long)
    pModule_Nr = lModule_Nr
End Property

Property Get fA_Arr() As Variant
    fA_Arr = pA_Arr
End Property

Property Let fA_Arr(vA_Arr As Variant)
    pA_Arr = vA_Arr
End Property

Property Get fB_Arr() As Variant
    fB_Arr = pB_Arr
End Property

Property Let fB_Arr(vB_Arr As Variant)
    pB_Arr = vB_Arr
End Property

Property Get fC_Arr() As Variant
    fC_Arr = pC_Arr
End Property

Property Let fC_Arr(vC_Arr As Variant)
    pC_Arr = vC_Arr
End Property

Klassenmodul namens "clsSheet"

Option Explicit
Private pMax_Col                As Long
Private pMax_Row                As Long
Private pArray                  As Variant
Private pRange                  As Range
Private pA_Col                  As Long
Private pB_Col                  As Long
Private pC_Col                  As Long

Public Function get_Sheet_Data(cSheet As clsSheet, oSheet As Excel.Worksheet) As clsSheet

Dim oUsed_Range         As Range
Dim lLast_Col           As Long
Dim lLast_Row           As Long
Dim iCnt                As Integer
Dim vArray              As Variant
Dim lNr_Rows            As Long
Dim lNr_Cols            As Long

Dim lCnt                As Long


With oSheet
    lLast_Row = .Cells(.Rows.Count, "A").End(xlUp).Row
    lLast_Col = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With

oSheet.Activate
Set oUsed_Range = oSheet.Range(Cells(1, 1), Cells(lLast_Row, lLast_Col))
cSheet.fRange = oUsed_Range
lNr_Rows = oUsed_Range.Rows.Count
cSheet.fMax_Row = lNr_Rows
lNr_Cols = oUsed_Range.Columns.Count
cSheet.fMax_Col = lNr_Cols
ReDim vArray(1 To lNr_Rows, 1 To lNr_Cols)
vArray = oUsed_Range
cSheet.fArray = vArray

For lCnt = 1 To lNr_Cols
    Select Case vArray(1, lCnt)

        Case "A"
            cSheet.fA_Col = lCnt
        Case "B"
            cSheet.fB_Col = lCnt
        Case "C"
            cSheet.fC_Col = lCnt

    End Select
Next lCnt

Set get_Sheet_Data = cSheet

End Function

Property Get fMax_Col() As Long
    fMax_Col = pMax_Col
End Property

Property Let fMax_Col(lMax_Col As Long)
    pMax_Col = lMax_Col
End Property

Property Get fMax_Row() As Long
    fMax_Row = pMax_Row
End Property

Property Let fMax_Row(lMax_Row As Long)
    pMax_Row = lMax_Row
End Property

Property Get fRange() As Range
    Set fRange = pRange
End Property

Property Let fRange(oRange As Range)
    Set pRange = oRange
End Property

Property Get fArray() As Variant
    fArray = pArray
End Property

Property Let fArray(vArray As Variant)
    pArray = vArray
End Property

Property Get fA_Col() As Long
    fA_Col = pA_Col
End Property

Property Let fA_Col(lA_Col As Long)
    pA_Col = lA_Col
End Property

Property Get fB_Col() As Long
    fB_Col = pB_Col
End Property

Property Let fB_Col(lB_Col As Long)
    pB_Col = lB_Col
End Property

Property Get fC_Col() As Long
    fC_Col = pC_Col
End Property

Property Let fC_Col(lC_Col As Long)
    pC_Col = lC_Col
End Property

InformationsquelleAutor Trace