我是VBA excel的初学者
我编写了一个代码，根据我的要求自动过滤所有列。我的要求是，
这是我的代码：
Sub stack()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim filterrange As Range
Set ws1 = ThisWorkbook.Sheets("sheet1")
Set ws2 = ThisWorkbook.Worksheets.Add(after:=ActiveSheet)
ws2.Name = "abc"
Set filterrange = ThisWorkbook.Sheets("sheet1").Cells(2, ThisWorkbook.Sheets("sheet1").Cells(1, Columns.Count).End(xlToLeft).Column) ' get columns e.g. name, state, etc.
filterrange.AutoFilter Field:=11, Criteria1:=Array("GBR" _
, "MAD", "NCE", "="), Operator:=xlFilterValues
filterrange.AutoFilter Field:=21, Criteria1:="Yes" ' activeconnect
filterrange.AutoFilter Field:=24, Criteria1:="=" ' clustername
filterrange.AutoFilter Field:=6, Criteria1:= _
"<>*@sca.com*", Operator:=xlAnd ' e-mail
filterrange.AutoFilter Field:=10, Criteria1:=Array( _
"Madrid", "Sophia-antipolis"), Operator:=xlFilterValues
For Each cell In filterrange.CurrentRegion.SpecialCells(xlCellTypeVisible).Rows
If Cells(cell.Row, 24) = "" Then
Select Case Cells(cell.Row, 11).Value
Case "NCE"
Cells(cell.Row, 24) = "ncew.net"
Case "MAD"
Cells(cell.Row, 24) = "muc.net"
End Select
End If
Next cell
filterrange.SpecialCells(xlCellTypeVisible).Copy
ws2.Activate
ws2.Range("a1").PasteSpecial (xlPasteValues)
End Sub
我的代码在两个不同的表格中显示相同的结果（即sheet1和sheet2）。 sheet1中的实际数据必须保持不变，结果应显示在sheet2中。任何人都可以帮助我。
答案 0 :(得分：0)
如果我理解你的问题，进行以下更改会有所帮助，
根据你的代码，你的r循环通过你的过滤条件并再次粘贴在sheet1中，而不是将其赋予sheet1，在这里指定sheet2
'如果你有列标题，则增加另一个1
introw = 1
intcol = 1
For Each cell In filterrange.CurrentRegion.SpecialCells(xlCellTypeVisible).Rows
If Cells(cell.Row, 24) = "" Then
Select Case Cells(cell.Row, 11).Value
Case "NCE"
ws2.Cells(introw, intcol ) = "ncew.net"
Case "MAD"
ws2.Cells(introw, intcol ) = "muc.net"
End Select
End If
introw = introw + 1
Next cell
答案 1 :(得分：0)
在回复您的评论时，以下代码显示了如何实现您所寻求的效果。我同时提出了一些建议/要点。
Option Explicit
Sub Demo()
Dim colWs1Last As Long
Dim rngFilter As Range
Dim rngCopy As Range
Dim rowWs1Last As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
' ThisWorkbook references the workbook containing the macro.
' Unless you are executing macros in another workbook you
' do not need to specifiy the workbook
Set ws1 = Worksheets("Sheet1")
' I do not reference the ActiveSheet unless the workbook has several
' similar worksheets and the user can run the macro against any of them.
' In other situations, use of ActiveSheet relies on the user having the
' correct worksheet active when the macro is started.
On Error Resume Next ' Switch off error handling
Set ws2 = Worksheets("abc")
On Error GoTo 0 ' Restore error handling
If ws2 Is Nothing Then
' Worksheet abc does not exist
Set ws2 = Worksheets.Add(After:=ws1)
ws2.Name = "abc"
Else
' abc already exists. Clear it of existing data and make it the
' active worksheet to match state after it has been created.
With ws2
.Cells.EntireRow.Delete
.Activate
End With
End If
With ws1
' I do not like statements where I have to carefully work along it before I know
' what it does. The problem is not that such statements do not work reliably but
' that anyone who has update the macro in 6 or 12 months will have to spend time
' decoding the statement. I believe the function of each of these statements
' will be obvious to any maintenance programmer and so will not waste their time
rowWs1Last = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
colWs1Last = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
Set rngFilter = .Range(.Cells(1, 1), .Cells(rowWs1Last, colWs1Last))
' Switch off AutoFilter if it is on
If .AutoFilterMode Then
.AutoFilter.Range.AutoFilter
End If
End With
With rngFilter
' I do not have your data so have not used your AutoFilter specification
' Replace with your specification.
.AutoFilter Field:=1, Criteria1:="D"
Set rngCopy = .SpecialCells(xlCellTypeVisible)
.AutoFilter ' Switch off AutoFilter
End With
' Copy rows left visible by filter to worksheet abc
rngCopy.Copy ws2.Cells(1, 1)
' Extra code in response to request for further help
' ==================================================
' Avoid the use of literals for column numbers. If a new column is
' added or if the columns are resequenced, you will have to work
' through your code line by line to identify which literals are
' column numbers to be changed and which literals are something else
' and are to be left alone. Probably not too difficult with column
' 24 but a nightmare when a low numbered column moves. Constants
' make your code easier to read and if the column does move,
' one change completes the update of your code.
Const ColCusterName As Long = 24
' I could calculate the number of rows from rngCopy but I prefer to
' treat the fixing of values in the new worksheet as a new problem.
Dim rngToUpdate As Range
Dim rowWs2Last As Long
With ws2
rowWs2Last = .Cells(Rows.Count, ColCusterName).End(xlUp).Row
Set rngToUpdate = .Range(.Cells(2, ColCusterName), _
.Cells(rowWs2Last, ColCusterName))
End With
With rngToUpdate
.Replace What:="NCE", Replacement:="ncew.net", LookAt:=xlWhole, MatchCase:=False
.Replace What:="MAD", Replacement:="muc.net", LookAt:=xlWhole, MatchCase:=False
End With
' Copy column widths from Sheet1 to sheet abc
ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, colWs1Last)).Copy
ws2.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
' Keep header row on scrren when scroll down
ws2.Cells(2, 1).Select
ActiveWindow.FreezePanes = True
End Sub
答案 2 :(得分：0)
如果可能，每手一次在工作簿中添加第二张工作表，并且每次都选择它。尝试一下，让我们知道，如果它对你来说足够了
Sub stack()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim filterrange As Range
Set ws1 = ThisWorkbook.Sheets("sheet1")
Set ws2 = ThisWorkbook.Sheets(2)
ws2.Name = "abc"
Set filterrange = ThisWorkbook.Sheets("sheet1").Cells(2, ThisWorkbook.Sheets("sheet1").Cells(1, Columns.Count).End(xlToLeft).Column) ' get columns e.g. name, state, etc.
filterrange.AutoFilter Field:=11, Criteria1:=Array("GBR" _
, "MAD", "NCE", "="), Operator:=xlFilterValues
filterrange.AutoFilter Field:=21, Criteria1:="Yes" ' activeconnect
filterrange.AutoFilter Field:=24, Criteria1:="=" ' clustername
filterrange.AutoFilter Field:=6, Criteria1:= _
"<>*@sca.com*", Operator:=xlAnd ' e-mail
filterrange.AutoFilter Field:=10, Criteria1:=Array( _
"Madrid", "Sophia-antipolis"), Operator:=xlFilterValues
filterrange.SpecialCells(xlCellTypeVisible).Copy
ws2.Activate
ws2.Range("a1").PasteSpecial (xlPasteValues)
for each cell in ws2.Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Cells(cell.Row, 24) = "" Then
Select Case Cells(cell.Row, 11).Value
Case "NCE"
Cells(cell.Row, 24) = "ncew.net"
Case "MAD"
Cells(cell.Row, 24) = "muc.net"
End Select
End If
Next cell
End Sub