rescuede
10-25-2005, 02:48 AM
HI All ,can any one see why does the following code not work?
I want to find in all sheets (same workbook) cells filling data with specific format and export all of them in one new general sheet.(same col)
Then after that i want that all cells in new general sheet dont contain any value like the rest of cells ( no duplicate name,maybe some cells with dup licate name must be deleted).And maybe i need a function that it can write the name of sheets of cells .That means many cells of difference sheets containing same value will be exported to one cell with difference names of sheets .The name of sheets can be written in same row with cell but in different columns
I dont have much time and cant find the erros by using debug.It does nothing
Thanks in advance.
Sub main2()
Dim rngSource As Range, rngHeadings As Range
Dim tcount As Integer
Dim r As Long, s As Long, q As Integer
Dim rowNum As Integer
Set rngHeadings = Sheets("Kriterien").Cells(lastRow(), 1)
For s = 2 To ActiveWorkbook.Sheets.count - 2
ActiveWorkbook.Sheets(s).Select
'tcount = lastRow()
For q = 6 To lastRow()
If (Sheets(s).Cells(q, "J").Font.Color = 3) Then
If (Sheets(s).Cells(q, "J").Font.Bold = True) Then
Sheets(s).Cells(q, "J").Select
Selection.Copy
rngHeadings.Paste
' rowNum = rowNum + 1
End If
End If
If (Sheets(s).Cells(q, "J").Font.Color = 4) And _
(Sheets(s).Cells(q, "J").Font.Bold = True) Then
'rngHeadings.Value = Cells(q, "J").Value
Sheets(s).Cells(q, "J").Select
Selection.Copy
rngHeadings.Paste
'rowNum = rowNum + 1
End If
Next q
Next s
End Sub
I want to find in all sheets (same workbook) cells filling data with specific format and export all of them in one new general sheet.(same col)
Then after that i want that all cells in new general sheet dont contain any value like the rest of cells ( no duplicate name,maybe some cells with dup licate name must be deleted).And maybe i need a function that it can write the name of sheets of cells .That means many cells of difference sheets containing same value will be exported to one cell with difference names of sheets .The name of sheets can be written in same row with cell but in different columns
I dont have much time and cant find the erros by using debug.It does nothing
Thanks in advance.
Sub main2()
Dim rngSource As Range, rngHeadings As Range
Dim tcount As Integer
Dim r As Long, s As Long, q As Integer
Dim rowNum As Integer
Set rngHeadings = Sheets("Kriterien").Cells(lastRow(), 1)
For s = 2 To ActiveWorkbook.Sheets.count - 2
ActiveWorkbook.Sheets(s).Select
'tcount = lastRow()
For q = 6 To lastRow()
If (Sheets(s).Cells(q, "J").Font.Color = 3) Then
If (Sheets(s).Cells(q, "J").Font.Bold = True) Then
Sheets(s).Cells(q, "J").Select
Selection.Copy
rngHeadings.Paste
' rowNum = rowNum + 1
End If
End If
If (Sheets(s).Cells(q, "J").Font.Color = 4) And _
(Sheets(s).Cells(q, "J").Font.Bold = True) Then
'rngHeadings.Value = Cells(q, "J").Value
Sheets(s).Cells(q, "J").Select
Selection.Copy
rngHeadings.Paste
'rowNum = rowNum + 1
End If
Next q
Next s
End Sub