KEMBAR78
Debit Balance Report Code | PDF
Scribd
Upload
13 views1 page

Debit Balance Report Code

This VBA macro filters data from one worksheet to a new worksheet based on certain criteria. It finds the last row of data, copies the header row to the new worksheet, then loops through each row checking if the value in column A meets one of three criteria ranges. If it matches, the entire row is copied to the new worksheet. Finally, it deletes any blank rows and auto-fits the columns.

Uploaded by

Ali
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
13 views1 page

Debit Balance Report Code

This VBA macro filters data from one worksheet to a new worksheet based on certain criteria. It finds the last row of data, copies the header row to the new worksheet, then loops through each row checking if the value in column A meets one of three criteria ranges. If it matches, the entire row is copied to the new worksheet. Finally, it deletes any blank rows and auto-fits the columns.

Uploaded by

Ali
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/ 1

Sub FilterData()

'Declare variables
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim i As Long
Dim j As Long

'Set ws variable to the worksheet you want to filter


Set ws = ThisWorkbook.Sheets("Sheet1")

'Find last row of data in column A


lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

'Create new worksheet for filtered data


ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name
= "FilterData"

'Copy header to new sheet


ws.Range("A1:G1").Copy ThisWorkbook.Sheets("FilterData").Range("A1")

'Loop through each row


For i = 2 To lastRow
'Check if value in column A is between 371028 and 371199 or between 381054 and
381199 or between 481021 and 481199
If ws.Cells(i, "A").Value >= 371028 And ws.Cells(i, "A").Value <= 371199 Or
ws.Cells(i, "A").Value >= 381054 And ws.Cells(i, "A").Value <= 381199 Or
ws.Cells(i, "A").Value >= 481021 And ws.Cells(i, "A").Value <= 481199 Then
'If the criteria is met, copy the entire row to the new sheet
ws.Rows(i).Copy ThisWorkbook.Sheets("FilterData").Rows(j + 2)
j = j + 1
End If
Next i

'Delete all blank rows in the new sheet


With ThisWorkbook.Sheets("FilterData")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lastRow To 2 Step -1
If Application.CountA(.Rows(i)) = 0 Then
.Rows(i).Delete
End If
Next i
End With

'Autofit rows in the new sheet


ThisWorkbook.Sheets("FilterData").Columns.AutoFit

End Sub

You might also like