JAVEDR
Board Regular
- Joined
- Sep 17, 2019
- Messages
- 79
- Office Version
- 2019
- Platform
- Windows
- Mobile
- Web
Greetings of day, I have macro which work for single condition but all time I have to change condition as multiple condition which is not feasible any help to modify same current macro as follow
result below =
modification needed
1. I'm looking for combination of second last and last row of range, want to filter rows where the values in cells C468 and C469 match a specific condition (e.g., both cells contain a specific number), and then copy the entire set of rows that match this condition to a new sheet.
2. Conditions are multiple like b468 and b469 , b468 and c469, b468 and d469, b468 and e469, b468 and f469, b468 and g469, b468 and h469, b468 and i469
, b468 and j469, b468 and k469, b468 and l469,b468 and m469, b468 and n469, b468 and o469,b468 and p469, b468 and q469, b468 and r469, b468 and s469. repeat the same for cell c , d , e , f , g , h till s and result will be collected in new sheet and highlight that condition
I know above is bit complicated to understand , trying best to make it easy. Thank you for your valuable time and suggestions
VBA Code:
Sub CopyDataToNewSheet()
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim lastRow As Long
Dim startRow As Long
Dim i As Long
Dim destRow As Long
Dim copyRange As Range
Dim condition As String
' Set the source sheet (adjust the sheet name as needed)
Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
' Add a new sheet for the destination
Set destinationSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
destinationSheet.Name = "NewSheet"
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "C").End(xlUp).row
destRow = 2 ' Start from row 2 on the destination sheet (to leave room for headers)
startRow = 2 ' Assuming your data starts in row 2
' Get the condition from cells C468 and C469
condition = sourceSheet.Cells(468, "C").Value & sourceSheet.Cells(469, "C").Value
' Copy header row to the destination sheet
sourceSheet.Range("A1:V1").Copy destinationSheet.Range("A1")
' Adjust column widths on the destination sheet
destinationSheet.Columns.AutoFit
For i = startRow To lastRow
' Check if the condition is met for each set of rows
If sourceSheet.Cells(i, "C").Value & sourceSheet.Cells(i + 1, "C").Value = condition Then
If copyRange Is Nothing Then
Set copyRange = sourceSheet.Range("A" & i & ":V" & i + 1)
Else
Set copyRange = Union(copyRange, sourceSheet.Range("A" & i & ":V" & i + 1))
End If
ElseIf Not copyRange Is Nothing Then
' If the condition is not met, but we have a copyRange, then copy and reset it
copyRange.Copy destinationSheet.Range("A" & destRow)
destRow = destRow + copyRange.Rows.Count
' Insert a blank row after each set of results
destRow = destRow + 1
Set copyRange = Nothing
End If
Next i
' Copy the last range if there's any remaining
If Not copyRange Is Nothing Then
copyRange.Copy destinationSheet.Range("A" & destRow)
End If
MsgBox "Data copied successfully!", vbInformation
End Subresult below =
| Date | OP | JOD | CP | OP | JOD | CP | OP | JOD | CP | OP | JOD | CP | OP | JOD | CP | OP | JOD | CP | OP | JOD | CP |
| 17-Nov-14 | 457 | -14- | 180 | 359 | -12- | 556 | 479 | -40- | 270 | 477 | -23- | 570 | 459 | -13- | 259 | 123 | -10- | 550 | 189 | -13- | 790 |
| 24-Nov-14 | 158 | -40- | 267 | 458 | -12- | 600 | 580 | -34- | 469 | 126 | -40- | 145 | 478 | -24- | 246 | 379 | -34- | 170 | 345 | -24- | 199 |
| 25-Jul-16 | 290 | -14- | 360 | 240 | -11- | 268 | 128 | -13- | 459 | 167 | -34- | 468 | 138 | -24- | 680 | 559 | -34- | 166 | 330 | -14- | 248 |
| 1-Aug-16 | 379 | -40- | 578 | 118 | -50- | 339 | 478 | -24- | 179 | 223 | -20- | 249 | 158 | -34- | 558 | 114 | -13- | 599 | 478 | -34- | 256 |
| 13-Aug-18 | 236 | -14- | 180 | 234 | -34- | 567 | *** | *** | 150 | -10- | 668 | 499 | -12- | 335 | 370 | -50- | 780 | 490 | -13- | 457 | |
| 20-Aug-18 | 130 | -40- | 889 | 238 | -33- | 445 | 146 | -14- | 248 | 268 | -12- | 156 | 399 | -14- | 234 | 470 | -11- | 128 | *** | *** | |
| 17-Jul-23 | 360 | -14- | 358 | 790 | -11- | 470 | 268 | -13- | 440 | 224 | -33- | 125 | 478 | -44- | 450 | 600 | -12- | 124 | 460 | -40- | 469 |
| 24-Jul-23 | 460 | -40- | 469 | 456 | -20- | 499 | 456 | -20- | 499 | 567 | -23- | 679 | 667 | -24- | 160 | 130 | -24- | 147 | 0 | 0 | |
modification needed
1. I'm looking for combination of second last and last row of range, want to filter rows where the values in cells C468 and C469 match a specific condition (e.g., both cells contain a specific number), and then copy the entire set of rows that match this condition to a new sheet.
2. Conditions are multiple like b468 and b469 , b468 and c469, b468 and d469, b468 and e469, b468 and f469, b468 and g469, b468 and h469, b468 and i469
, b468 and j469, b468 and k469, b468 and l469,b468 and m469, b468 and n469, b468 and o469,b468 and p469, b468 and q469, b468 and r469, b468 and s469. repeat the same for cell c , d , e , f , g , h till s and result will be collected in new sheet and highlight that condition
I know above is bit complicated to understand , trying best to make it easy. Thank you for your valuable time and suggestions
