How to display result in another sheet rather showing in the same sheet in excel using vba?

Question

Hi Im beginner to VBA excel

I have written a code which autofilter all the columns to my requirement. My requirement is ,

1. the result has to be displayed in new sheet(say sheet2) rather showing in the same sheet(say sheet1).
2. Suppose, if i excute the code mutiple times, it always open only one sheet( i.e sheet2) not many sheets as well as it auto refresh the sheet2 if i excute the code again and must display the expected result.

Here is my code:

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

My code is showing same result in two different sheets( i.e sheet1 and sheet2). The actual data must remain unchanged in sheet1 and the result should be displayed in sheet2. can anyone please help me out.

Answer 1

if i understood your problem correctly , making the below changes will help,

as per you r code, your r looping thru ur filter criteria and pasting again in sheet1 , instead of giving it to sheet1, specify the sheet2 here

'if u have column headers, increment introw by another 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

u can comment the copy and pastespecial line of code

Answer 2

If possible add a second sheet to your workbook per hand once and select it every time. try this out and let met know, if it's sufficient for you

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

Answer 3

In response to your comment, the following code shows how would achieve the effect you seek. I have made a few suggestions/points at the same time.

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