Solved: Copy from one xls to other avoiding highlighted cells

[jigar1276]

Hi Experts,

I have two xls files. The "data.xls" contains the 2 columns (A & B) list with N numbers of rows. The "report.xls" is having blank format containing 2 columns and only 10 rows to acomodated top 10 data.

The certain cells in column "B" of "data.xls" is highlighted using color which needs to be ignored while preparing the report.

The macro should acsending short the "data.xls" and then copy the 10 rows in "report.xls" by avoiding rows for which cells in column "B" of "data.xls" is highlighted using color.

I have tried using the following code, but in case of one highlighted cell, the 9 rows only copied to report file. if i highlight 2 cells, only 8 rows copied to report file. I need 10 rows in the report.

Thanks...

Sub PI()
'
'
'
Dim srnofrm As Long, srnoto As Long
Dim repf As String, dataf As String
pastpos = 10
srnofrm = 1
srnoto = 10
Windows("Data.xls").Activate
dataf = "Sheet" & Sht
Sheets(dataf).Select
Columns("A : D").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For srno = srnofrm To srnoto
Windows("Data.xls").Activate
dataf = "Sheet" & Sht
Sheets(dataf).Select
If Range("B" & srno).Interior.ColorIndex <> 6 Then
Range("A" & srno & ":B" & srno).Select
Selection.Copy
Windows("TOP_PI.xls").Activate
repf = "Sheet " & Sht
Sheets(repf).Select
Range("B" & pastpos).Select
ActiveSheet.Paste
pastpos = pastpos + 1
Else
srnoto = srnoto + 1
End If
Next srno
End Sub

[figment]

try this

[VBA]Sub Pl()
'
'
'
Dim srno As Long, srnoto As Long
Dim repf As String, dataf As String
pastpos = 10
srno = 1
srnoto = 11
dataf = "Sheet" & Sht
Windows("Data.xls").Sheets(dataf).Columns("A : D").Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
While srno <> srnoto
dataf = "Sheet" & Sht
With Windows("Data.xls").Sheets(dataf)
If .Range("B" & srno).Interior.ColorIndex <> 6 Then
repf = "Sheet " & Sht
.Range("A" & srno & ":B" & srno).Copy Windows("TOP_PI.xls").Sheets(repf).Range("B" & pastpos)
pastpos = pastpos + 1
Else
srnoto = srnoto + 1
End If
End With
srno = srno + 1
Wend
End Sub
[/VBA]

[jigar1276]

Thanks for your interest and help figment,

I tried the code but it gives the error "438-Object doesn't support this property or method" for the code line "With Windows("Data.xls").Sheets(dataf)"

I am using Excel 2002 (10.2614.2625)

Please guide me.

Thanks again.

[figment]

try replacing Sheets with Worksheets
and you might have to change windows to Workbooks

[jigar1276]

Hi figment,

As per your guidence, I tried below code:
[vba]
While srno <> srnoto
dataf = "Sheet" & Sht
With Workbooks("Data.xls").Worksheets(dataf)
If .Range("B" & srno).Interior.ColorIndex <> 6 Then
repf = "Sheet " & Sht
.Range("A" & srno & ":B" & srno).Copy Workooks("TOP_PI.xls").Wroksheets(repf).Range("B" & pastpos)
pastpos = pastpos + 1
srno = srno + 1
Else
srnoto = srnoto + 1
End If
End With
srno = srno + 1
Wend
[/vba]

It is giving the run time error '9': Subscript out of range for the line "
.Range("A" & srno & ":B" & srno).Copy Workooks("TOP_PI.xls").Wroksheets(repf).Range("B" & pastpos)
"
Also, I have tried putting my code as bellow:

[vba]
while srno <= srnoto
windows("Data.xls").Active
dataf = "Sheet" & Sht
sheets(dataf).select
If Range("B" & srno).Interior.ColorIndex <> 6 Then
Range ("A" & srno & ":B" & srno).Select
Selection.Copy
Windows("TOP_PI.xls").Activate
repf="SHIFT " & Sht
Range("B" & pastpos).Select
Activesheet.paste
pastpos = pastpos+1
srno=srno+1
Else
srnoto = srnoto+1
end if
wend

[/vba]

The above code is working fine if any highlighted cells are NOT there in "Data.xls". In case of one highlighted cell in "Data.xls" the code is pasting only 9 rows instead of 10. In case of two highlighted cells in "Data.xls" the code is pasting only 8 rows instead of 10.

So, I think the code line "srnoto = srnoto+1" is not working which is placed in If Then Else statement. I dont know the reason for that. Please guide.

[jigar1276]

problem solved figment,

i made small change in the code as follow:

[VBA]

While srno <= srnoto
windows("Data.xls").Active
dataf = "Sheet" & Sht
sheets(dataf).select
If Range("B" & srno).Interior.ColorIndex <> 6 Then
Range ("A" & srno & ":B" & srno).Select
Selection.Copy
Windows("TOP_PI.xls").Activate
repf="SHIFT " & Sht
Range("B" & pastpos).Select
Activesheet.paste
pastpos = pastpos+1
srno=srno+1
Else
srno=srno+1
srnoto = srnoto+1
End If
Wend

[/VBA]

Thanks for your help which gave me the logic to accomplish this task.

[figment]

good to see you got it working, but i would still strive to this task without select statements. as you you second to last post, you had a small typo which was probably causing the problem

.Range("A" & srno & ":B" & srno).Copy Workooks("TOP_PI.xls").Wroksheets(repf).Range("B" & pastpos)

should be

.Range("A" & srno & ":B" & srno).Copy Workbooks("TOP_PI.xls").Wroksheets(repf).Range("B" & pastpos)