PDA

View Full Version : change in VBA



abdulncr
11-16-2012, 12:17 AM
Hi,

I have below code to extract from one sheet to another, i wanted to add three things more points to the code, could any one please help me.

1) it is extracting from only one sheet i have 10 sheet extracted one by one sheet name suresh,george,mathew....etc
2) eg:- if more than one cell not equal to "Y" in H9:H28, more than one row extracting. i wanted to extract only one.
3)in the D7 of sheet extract i have MMM-yy, i wanted of extract if B9:B28 of each sheet equal to or less than D7 of sheet Extract.
4)if any row is hidden in the sheet it is not extracting, i wanted to extract that also without unhiding in the ooriginal sheet and sheet Extract

Sub copysheet()
Dim r As Range, sh As Worksheet
Set r = Worksheets("suresh").Range("H9:AC28")
Set sh = Worksheets("Extract")
For Each cell In r
If UCase(cell.Value) <> "Y" Then
rw = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row + 1
cell.EntireRow.Copy
If rw < 18 Then rw = 18
sh.Cells(rw, 1).PasteSpecial xlValues
sh.Cells(rw, 1).PasteSpecial xlFormats
End If
Next
End Sub

Thanks
Abdul

Bob Phillips
11-16-2012, 02:29 AM
Untested

Sub copysheet()
Dim r As Range, cell As Range, sh As Worksheet, ws As Worksheet

Set sh = Worksheets("Extract")
For Each ws In Worksheets(Array("suresh", "george", "Matthew"))

Set r = sh.Range("H9:AC28")
For Each cell In r
If Application.CountIf(sh.Range("B9:B28"), ">" & sh.Range("D7")) = 0 Then
If UCase(cell.Value) <> "Y" Then
rw = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row + 1
cell.EntireRow.Copy
If rw < 18 Then rw = 18
sh.Cells(rw, 1).PasteSpecial xlValues
sh.Cells(rw, 1).PasteSpecial xlFormats
Exit For
End If
End If
Next cell
Next ws
End Sub

abdulncr
11-16-2012, 07:14 AM
Hi Sir,

Thanks for your time granted from me.

after running the code nothing is extracting, it is hiding row number 18 in the Sheet Extract.
waiting for your reply.

Thanks
Abdul

Bob Phillips
11-16-2012, 11:13 AM
Post a workbook I can run it against.

abdulncr
11-16-2012, 12:52 PM
Post a workbook I can run it against.

HI,

File uploaded. vba password is sazss.

Thanks

Abdul

Bob Phillips
11-16-2012, 03:11 PM
Try this

Sub copysheet()
Dim r As Range, cell As Range, sh As Worksheet, ws As Worksheet

Set sh = Worksheets("Extract")
For Each ws In Worksheets(Array("george", "saad", "sujada"))

If Application.CountIf(ws.Range("B9:B28"), ">=" & sh.Range("D6")) = 0 Then

Set r = ws.Range("H9:AD28")
For Each cell In r

If UCase(cell.Value) <> "Y" Then

rw = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row + 1
cell.EntireRow.Copy
If rw < 18 Then rw = 18
sh.Cells(rw, 1).PasteSpecial xlValues
sh.Cells(rw, 1).PasteSpecial xlFormats
Exit For
End If
Next cell
End If
Next ws
End Sub

abdulncr
11-17-2012, 12:23 AM
Hi Sir,

tested new code, still have below problem.

1) In the sheets, george, saad,sujada, rows belong to one month is visible, rest all will be hidden. in this case extract is not working example check in the sheet george.

2) it is extracting only one row from each sheet and i wanted to extract one unique row in the C9:28 of each sheet.

Thanks
Abdul

Bob Phillips
11-17-2012, 01:55 AM
2) it is extracting only one row from each sheet and i wanted to extract one unique row in the C9:28 of each sheet.


Isn't one unique row only one row?

abdulncr
11-17-2012, 03:46 AM
Hi Sir,

one unique row

thanks

Abdul.

abdulncr
11-17-2012, 10:16 AM
HI,

It is one unique row matching with criteria mentioned.

All the sheet B9:28 less than or equal to D6 in sheet Extract.
It is to extract hided rows also unhidden in the sheet Extract.

Hope conveyed my question.

Thanks so much