Filtern Sie das Blatt und kopieren Sie die Auswahl auf ein neues Blatt mit VBA - Excel, VBA, Excel-Vba

Beim Versuch, die gefilterten Zellen in einer Schleife zu filtern und dann zu kopieren, wird die Fehlermeldung "Einfügemethode der Arbeitsblattklasse fehlgeschlagen" angezeigt.

Es scheint zu scheitern, weil ich eine Schleife verwende. Ich habe andere Methoden zum Einfügen von Spezialversuchen ausprobiert, aber dies scheint nicht zu funktionieren. Bitte helfen Sie

Sub Split()

Dim wsYes As Worksheet
Set wsYes = Worksheets("YES")

With wsYes

Dim myRange As Range
Set myRange = .Range("A2", .Range("A2").End(xlDown))

myRange.Copy .Cells(1, .Columns.Count) "copy to far right column
.Cells(1, .Columns.Count).Resize(myRange.Rows.Count, 1).RemoveDuplicates 1, xlNo

Set myRange = .Range(.Cells(1, .Columns.Count), .Cells(1, .Columns.Count).End(xlDown))

For Each MyCell In myRange



Dim sName As String
sName = UCase(MyCell.Value)


Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$B$9").AutoFilter Field:=1, Criteria1:= _
sName

Range("B:B").Select
Selection.Copy

Dim wsNew As Worksheet
Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count)) " creates a new worksheet
wsYes.Range("B:B").Copy
With wsNew
.Name = sName
.Range("A1").Value = "Column Name"
.Range("A1").Font.Bold = True
.Range("A2").Value = sName
.Range("B1").Select
ActiveSheet.Paste


End With

Next MyCell

myRange.Clear

End With



End Sub

Danke im Voraus

Antworten:

Sie müssen Kopieren und Einfügen zusammen haben, ohne andere Dinge zu tun wsNew Blatt

Sub Split()

Dim wsYes As Worksheet
Set wsYes = Worksheets("YES")

With wsYes

Dim myRange As Range
Set myRange = .Range("A2", .Range("A2").End(xlDown))

myRange.Copy .Cells(1, .Columns.Count) "copy to far right column
.Cells(1, .Columns.Count).Resize(myRange.Rows.Count, 1).RemoveDuplicates 1, xlNo

Set myRange = .Range(.Cells(1, .Columns.Count), .Cells(1, .Columns.Count).End(xlDown))

For Each MyCell In myRange

Dim sName As String
sName = UCase(MyCell.Value)

wsYes.Select
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$B$9").AutoFilter Field:=1, Criteria1:=sName

wsYes.Range("B:B").Select
Selection.Copy

Dim wsNew As Worksheet
Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count)) " creates a new worksheet

With wsNew
.Name = sName
.Range("A1").Value = "Column Name"
.Range("A1").Font.Bold = True
.Range("A2").Value = sName

" moved copy and paste tasks one after the other
wsYes.Range("B:B").Copy
.Columns("B:B").Select
ActiveSheet.Paste
End With

Next MyCell
myRange.Clear

End With

End Sub

Probieren Sie diesen Code aus.

Sub Split()

Dim MyCell As Range

Dim wsYes As Worksheet
Set wsYes = Worksheets("YES")

With wsYes

Dim myRange As Range
Set myRange = .Range("A2", .Range("A2").End(xlDown))

myRange.Copy .Cells(1, .Columns.Count) "copy to far right column
.Cells(1, .Columns.Count).Resize(myRange.Rows.Count, 1).RemoveDuplicates 1, xlNo

Set myRange = .Range(.Cells(1, .Columns.Count), .Cells(1, .Columns.Count).End(xlDown))

For Each MyCell In myRange



Dim sName As String
sName = UCase(MyCell.Value)

With wsYes
.Range("A1").Select
.Selection.AutoFilter
.Range("$A$1:$B$9").AutoFilter Field:=1, Criteria1:=sName

Dim wsNew As Worksheet
Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count)) " creates a new worksheet
End With
With wsNew
.Name = sName
.Range("A1").Value = "Column Name"
.Range("A1").Font.Bold = True
.Range("A2").Value = sName
.Range("B1").Select
wsYes.Range("B:B").Copy
ActiveSheet.Paste


End With

Next MyCell

myRange.Clear

End With



End Sub

Es scheint wie nach dem Machen A1 Fett es löschte einen Puffer, so dass Sie nichts kopiert hatten.