2016-08-10 11 views
3

と一致しないオートフィルタ(2列/ 2基準)コピー行:名前を持つエクセルVBA - 私は、次のVBAコードを使用するときの基準

With Range("A6:T" & lngLastRow) 
    .AutoFilter 
    .AutoFilter Field:=6, Criteria1:="Alexandra" 
    .AutoFilter Field:=19, Criteria1:="-14" 
    .Copy AlexSheet.Range("A3") 
    .AutoFilter 
End With 

それをコピーした行「アレクサンドラ」でautofilterフィールド6だけでなく、異なる名前と異なる値を持つ1〜2行を自動フィルターフィールド19にコピーします(-14ではなく)

Excel/VBAで何も求めなかった行をコピーする原因がわかりませんために。

誰かが私を助けてくれることを願っています。

完全なコード:データの

Sub DeleteFilterAndCopy() 

Application.ScreenUpdating = False 
Application.EnableEvents = False 
Application.Calculation = xlCalculationManual 

Sheets("Alex").Range("A3:T1000").clearcontents 
Sheets("Anett Edith").Range("A3:T1000").clearcontents 
Sheets("Angela").Range("A3:T1000").clearcontents 
Sheets("Dirk").Range("A3:T1000").clearcontents 
Sheets("Daniel").Range("A3:T1000").clearcontents 
Sheets("Klaus").Range("A3:T1000").clearcontents 
Sheets("Konrad").Range("A3:T1000").clearcontents 
Sheets("Marion").Range("A3:T1000").clearcontents 
Sheets("MartinX").Range("A3:T1000").clearcontents 
Sheets("Michael").Range("A3:T1000").clearcontents 
Sheets("Mirko").Range("A3:T1000").clearcontents 
Sheets("Nils").Range("A3:T1000").clearcontents 
Sheets("Ulrike").Range("A3:T1000").clearcontents 

Dim lngLastRow As Long 
Dim AlexSheet As Worksheet, AnettEdithSheet As Worksheet, AngelaShett As Worksheet, DanielSheet As Worksheet 
Dim DirkSheet As Worksheet, KlausSheet As Worksheet, Konradsheet As Worksheet 
Dim MarionSheet As Worksheet, MartinSheet As Worksheet, MichaelSheet As Worksheet, MirkoSheet As Worksheet 
Dim NilsSheet As Worksheet, Ulrikesheet As Worksheet 

Set AlexSheet = Sheets("Alex") 
Set AnettEdithSheet = Sheets("Anett Edith") 
Set AngelaSheet = Sheets("Angela") 
Set DanielSheet = Sheets("Daniel") 
Set DirkSheet = Sheets("Dirk") 
Set KlausSheet = Sheets("Klaus") 
Set Konradsheet = Sheets("Konrad") 
Set MarionSheet = Sheets("Marion") 
Set MartinSheet = Sheets("MartinX") 
Set MichaelSheet = Sheets("Michael") 
Set MirkoSheet = Sheets("Mirko") 
Set NilsSheet = Sheets("Nils") 
Set Ulrikesheet = Sheets("Ulrike") 

lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row 

With Range("A6:T" & lngLastRow) 
    .AutoFilter 
    .AutoFilter Field:=6, Criteria1:="Alexandra" 
    .AutoFilter Field:=19, Criteria1:="-14" 
    .Copy AlexSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Anett/Edith" 
    .Copy AnettEdithSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Angela" 
    .Copy AngelaSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Daniel" 
    .Copy DanielSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Dirk" 
    .Copy DirkSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Klaus" 
    .Copy KlausSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Konrad" 
    .Copy Konradsheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Marion" 
    .Copy MarionSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Martin" 
    .Copy MartinSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Michael" 
    .Copy MichaelSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Mirko" 
    .Copy MirkoSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Nils" 
    .Copy NilsSheet.Range("A3") 
    .AutoFilter Field:=6, Criteria1:="Ulrike" 
    .Copy Ulrikesheet.Range("A3") 
    .AutoFilter 
End With 

Application.ScreenUpdating = True 
Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 

End Sub 

スクリーンショット:filteresを取得し(オレンジ列=オートフィルタフィールド)からコピー

データ: enter image description here

問題ですマクロがPlanner Alexandraと-14の値を含む行をコピーするだけでなく、両方のセルで異なる値を持つ1-2行。

挨拶

+0

を試してみてください?これは、自動フィルタリングを混乱させる可能性があります。 –

+0

あなたが正しいのはその理由です。私はあなたの答えをマークすることができます投稿をしてください – Bluesector

+0

訂正ありがとう。 –

答えて

4

あなたはA5を通じてセルA1の値かしらこの

With Range("A6:T" & lngLastRow) 
    .AutoFilter Field:=6, Criteria1:="Alexandra" 
    .AutoFilter Field:=19, Criteria1:="-14" 
    .SpecialCells(xlCellTypeVisible).Copy AlexSheet.Range("A3") 
End With 
2
 It's ? like how are you coping autofiltered data.. 
    Copy only special rows 

    Range("A1").Select''Destination where want to paste 
    'Use below code to paste 
    Selection.PasteSpecial Paste:=xlPasteValue 
+0

機能がはるかに長く、15人と15人のために同じことをするので、selectは機能しません – Bluesector

+0

はあなたに既存の機能を投稿します。これが何であるかを理解するのに役立ちます –

+0

完了、 – Bluesector

2
'For each new FilterCombinations criteria call this sub or modify according to your need 
Sub Macro() 
Range("A1").Select ''Assuming that 1st row is for header 
ActiveCell.Offset(1, 0).Select 

Dim intSpRowCount As Integer 
intSpRowCount = Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Rows.count 

If Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Rows.count > 1 Then 
'copy only visible range 
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(intSpRowCount - 1, Int(ActiveSheet.UsedRange.Rows.count) - 1)).Select 
Selection.Copy 

Sheets("Sheet3").Select 
Range("A6").Select 
ActiveSheet.Paste 
End If 
End Sub 
関連する問題