KEMBAR78
Macro For Sheet Filtering | PDF
Scribd
Upload
34 views2 pages

Macro For Sheet Filtering

This VBA macro filters data from all worksheets in the source workbook, creating a new workbook with sheets that contain rows marked with 'E' in column A and columns labeled 'E' in the header. It copies the relevant headers and filtered data to the new sheets, limiting sheet names to 31 characters. The process concludes with a message box indicating the completion of the data transfer.

Uploaded by

joshikanak08
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
34 views2 pages

Macro For Sheet Filtering

This VBA macro filters data from all worksheets in the source workbook, creating a new workbook with sheets that contain rows marked with 'E' in column A and columns labeled 'E' in the header. It copies the relevant headers and filtered data to the new sheets, limiting sheet names to 31 characters. The process concludes with a message box indicating the completion of the data transfer.

Uploaded by

joshikanak08
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 2

Sub FilterSheets_EStatus_ToNewWorkbook()

Dim wbSrc As Workbook, wbNew As Workbook


Dim wsSrc As Worksheet, wsNew As Worksheet
Dim lastRow As Long, lastCol As Long
Dim i As Long, j As Long
Dim rowEList As Collection, colEList As Collection
Dim rowIndex As Variant, colIndex As Variant
Dim r As Long, c As Long
Dim sheetIndex As Integer

Set wbSrc = ThisWorkbook


Set wbNew = Workbooks.Add
sheetIndex = 1

Application.ScreenUpdating = False

' Loop through all sheets


For Each wsSrc In wbSrc.Worksheets
' Initialize collections
Set rowEList = New Collection
Set colEList = New Collection

' Get last used row & column


lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
lastCol = wsSrc.Cells(2, wsSrc.Columns.Count).End(xlToLeft).Column ' Adjust
header row here if needed

' Collect rows with 'E' in column A


For i = 3 To lastRow
If Trim(wsSrc.Cells(i, 1).Value) = "E" Then rowEList.Add i
Next i

' Collect columns with 'E' in row 1


For j = 1 To lastCol
If Trim(wsSrc.Cells(1, j).Value) = "E" Then colEList.Add j
Next j

' Skip if no matching rows or columns


If rowEList.Count = 0 Or colEList.Count = 0 Then GoTo SkipSheet

' Add new sheet to new workbook


If sheetIndex <= wbNew.Sheets.Count Then
Set wsNew = wbNew.Sheets(sheetIndex)
Else
Set wsNew = wbNew.Sheets.Add(After:=wbNew.Sheets(wbNew.Sheets.Count))
End If
wsNew.Name = Left(wsSrc.Name & "_Filtered", 31) ' Limit to 31 characters

' Copy column headers (from Row 2 of source sheet)


c = 1
For Each colIndex In colEList
wsNew.Cells(1, c).Value = wsSrc.Cells(2, colIndex).Value
c = c + 1
Next colIndex

' Copy filtered data


r = 2
For Each rowIndex In rowEList
c = 1
For Each colIndex In colEList
wsNew.Cells(r, c).Value = wsSrc.Cells(rowIndex, colIndex).Value
c = c + 1
Next colIndex
r = r + 1
Next rowIndex

sheetIndex = sheetIndex + 1

SkipSheet:
Next wsSrc

Application.ScreenUpdating = True
MsgBox "Filtered data copied to new workbook.", vbInformation
End Sub

You might also like