Find cells in mutiple sheets and export in one sheet

[rescuede]

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.

[vba]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[/vba]

[Killian]

Hi and welcome to VBAX

If you're short on time, attach the workbook, since anyone attempting to test your code has to replicate your worksheet structure and formatting (Zip the workbook, Click the "Go Advanced" button, go to "Manage Attachments" and attach the zipped file)
Have you checked your lastRow() function is returning something appropriate - I can see how that would make it do nothing...

Also, I think you mean to use ColorIndex, rather than Color (which is the color value as a Long) when checking the font

[Killian]

And now I look a little closer, when you paste the value into the defined range, you need to use PasteSpecial (and add the appropriate argument) e.g.[VBA]rngHeadings.PasteSpecial xlPasteValues[/VBA]

[rescuede]

I rewrote my code again and can finish 1.step but to insert the mass and del duplicate names i still cant solve

Thanks for fast reply .

[Killian]

I've made some changes to the For Next loop and incorporated a Find to check if the entry already exists and another one to get the Mass... seems to work ok[VBA]Sub outputCriterion3(colNum As Integer)
Dim rngTarget As Range, rngHeadings As Range, rngHeadings1 As Range
Dim tcount As Integer
Dim r As Long, s As Long, q As Integer, i As Integer, j As Integer, x As Integer
Dim rowNum As Integer
Dim sh As Worksheet
Dim rngMass As Range
Dim rngDupe As Range

Dim shname As String
rowNum = 1

For Each sh In ActiveWorkbook.Worksheets
shname = sh.Name
If (shname <> "Kriterien") And (shname <> "Mass") Then
sh.Select
For q = 2 To lastRow()
With sh.Cells(q, "J").Font
If .ColorIndex = 3 Or .ColorIndex = 10 Then
If .Bold = True Then
Set rngHeadings = Worksheets("Kriterien").Cells(rowNum + 1, 1)
Set rngHeadings1 = Worksheets("Kriterien").Cells(rowNum + 1, colNum)
'check for existing entry
Set rngDupe = Worksheets("Kriterien").Cells.Find(Cells(q, "J").Value, LookIn:=xlValues)
If rngDupe Is Nothing Then
rngHeadings.Value = Cells(q, "J").Value
rngHeadings1.Value = shname
rowNum = rowNum + 1
End If
'find and add mass
Set rngMass = Worksheets("Mass").Cells.Find(rngHeadings.Value, LookIn:=xlValues)
If Not rngMass Is Nothing Then
rngHeadings.Offset(0, 1).Value = rngMass.Offset(0, 1).Value
End If
End If
End If
End With
Next q
End If
Next sh

End Sub[/VBA]

[rescuede]

Srry for the late reply.Actually the database is complex with alot of streams and sub directorys.


_I success to export it in one sheet by using ur find method and set the range closer.

_but still get some problem by del duplication name .It is important to get an good overview to analyse the data base.

Will be great if u know any other ways to do it