EXCEL - VBA - színkereső - kigyűjtő

Programozás - kezdő

░░░░░░░░░░░░░
░ MEGOLDVA! ░
░ KÖSZÖNÖM! ░
░░░░░░░░░░░░░

Sziasztok!

Van két file:
adatok.xls
scriptek.xlsm

Az adatok.xls tartalma sok munkafüzetlapból áll.
Minden munkafüzetlapon van egy sor amiben van egy sárga cella, de mindig másik sorban.
(Odáig már eljutottam, hogy minden munkafüzetlapon a keresett sor egyik cellája legyen citromsárga.)
A cél az lenne, hogy minden olyan sort ahol van citromsárga cella, másolja
át a scriptek.xlsm munkafüzetlap2-be, ami a kigyűjtést követően lesz jópár soros a végén.
Van esetleg valakinek "link" ötlete, ahol már találkozott ilyennel, vagy okos és már megoldott ilyet?

  • 2524 megtekintés

( takitibi | 2015. 01. 06., k – 10:40 )

találtam ilyet:
http://www.techonthenet.com/excel/downloads/search_for_string.zip
Ez az első fülről keres szóra, és ha talál az egész sort átdobja a
második fülre. Találtam egy scriptet, amiben olyan van, hogy nem előre definiált a kulcsszó, hanem bekéri a gép egy kis dobozba. Ezt hogy lehetne
beleintegrálni?

Itt a bekérős script (InputBox parancs a nyerő!):
~~~~~~~~~~~~~~~~~~~~~~
Sub SrchIDs()
Dim rId As Range, celS As Range, celT As Range
Dim wS As Worksheet, wT As Worksheet
Dim sId As String
Set wS = Worksheets("Sheet1")
Set wT = Worksheets("Sheet2")
Set celT = wT.Range("A1")
Do
sId = InputBox("Enter ID")
If Len(sId) = 0 Then Exit Sub
Set rId = wS.Range("D4") 'start of search area
Set rId = wS.Range(rId, wS.Cells(wS.Rows.Count, rId.Column).End(xlUp)) 'rest of data
Set celS = rId.Find(sId, , xlValues, xlWhole, , , False)
If Not celS Is Nothing Then
Set celS = Intersect(wS.Columns("F:F"), celS.EntireRow) 'extract name
If Not IsEmpty(celT) Then 'find next empty cell in target sheet
Set celT = wT.Cells(wT.Rows.Count, celT.Column).End(xlUp).Offset(1)
End If
celT.Value = celS.Value
End If
Loop Until Len(sId) = 0
End Sub

És az a baj, hogy az adatok.xls-ben nem sheet1 és sheet2 a neve a munkalapfüleknek, hanem mindig más és más :: alma, körte, szőlő, autó, ...

Sub GetSheetNames()
Dim wSheet As Worksheet
  For Each wSheet In Worksheets
    On Error Resume Next
    ActiveCell.Value = wSheet.Name
    ActiveCell.Offset(1, 0).Select
  Next wSheet
End Sub

Ebből kibogarászhatod, hogyan veheted sorra a worksheeteket.
Read more : http://www.ehow.com/how_8503026_list-worksheets-excel-using-vba.html

Üdv,
Marci

Szia!
http://takitibi.hu/excel/proba.xlsm
idáig jutottam, lefut, de nem értem, nem pakolja át a gyujto fülre a kért
sorokat. Ki tudnád próbálni, megnézni? Görcsölök rajta, de nem ez a szakterületem, és borzasztóan izzadok ettől... Köszönöm előre is!
---
Üdv: TakiTibi

Frissítve:
Külön "nyomógombként" a lapfülnév kigyűjtő kigyűjti most már a neveket a GYŰJTŐ fül A40-es cellájától lefelé. Így már lehet hivatkozni a cellanévre!
Jó ez így, talán még ma készen leszek vele.

------------
Szia!
Hihetetlen, köszönöm szépen! :-) Nagy Guru vagy! Valóban így már működik.
Ez azt jelenti, hogy lentebbi sorból (5.sor) kezdje scannelni az oszlopot?
Lefut frankó! Már csak a Marci(mrceeka) féle ügyet kellene belerakni, hogy az összes munkalapfülön keresztülmenjen, amik más más nevűek.
Köszi az eddigieket is!
---
Üdv: TakiTibi