Как отобразить результат на другом листе, который отображается на одном листе в excel с помощью vba?

Question

Hi Im beginner to VBA excel

Я написал код, который автофильтрует все столбцы по моему требованию. Мое требование:

1. результат должен быть отображен на новом листе (например, sheet2), скорее показывая на том же листе (скажем, на листе 1).
2. Предположим, если я искупил код несколько раз, он всегда открывает только один лист (i.e sheet2) не так много листов, а также его автообновление sheet2, если я еще раз измучу код и должен отобразить ожидаемый результат .

Вот мой код:

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). Фактические данные должны оставаться неизменными в листе1, и результат должен отображаться на листе2. может кто-нибудь, пожалуйста, помогите мне.

Answer 1

В ответ на ваш комментарий следующий код показывает, как добиться эффекта, который вы ищете. Я сделал несколько предложений/пунктов одновременно.

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 

Answer 2

, если я понял вашу проблему правильно, делая ниже изменения помогут,

согласно вам г код, ваш г перекручивание через ур критериев фильтрации и снова вставить в sheet1, вместо того, чтобы отдать его Лист1, указать sheet2 здесь

«, если и есть заголовки столбцов, приращение introw еще на 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 

и может прокомментировать копию и pastespecial строку кода

Answer 3

Если возможно, добавьте второй лист в свою книгу в руке один раз и выберите его каждый раз. попробуйте это и сообщите, если вам это достаточно.

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