Excel 2007 Vba søke etter verdi i flere ark, sette funnet verdi i "variabel" celle i et annet ark

[Bigelk]

Hei.

 

Jeg prøver og hente ut informasjon i fra flere ark, for så å sette den informasjonen jeg er ute etter i et annet ark.

Jeg har funnet en kode som jeg prøver og modifisere.

 

Problemstilling:

for hver gang den har satt variablen S2 vil jeg at cellen den setter Verdien i flyttes en til høyre.

 

Poster hele koden her så man ser hvordan den fungerer, så poster jeg den delen som må fikses litt på under

Dim sheetCount As Integer
Dim datatoFind
Sub Knapp1_klikk()
Find_Data
End Sub
Private Sub Find_Data()
   Dim counter As Integer
   Dim currentSheet As Integer
   Dim notFound As Boolean
   Dim yesNo As String

   notFound = True
   On Error Resume Next
   currentSheet = ActiveSheet.Index
   datatoFind = StrConv(InputBox("Please enter the value to search for"), vbLowerCase)
   If datatoFind = "" Then Exit Sub
   sheetCount = ActiveWorkbook.Sheets.Count
   If IsError(CDbl(datatoFind)) = False Then datatoFind = CDbl(datatoFind)
   For counter = 1 To sheetCount
    Sheets(counter).Activate
    Cells.Find(What:=datatoFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate
    If InStr(1, StrConv(ActiveCell.Value, vbLowerCase), datatoFind) Then
	    notFound = False
	    S1 = ActiveCell.Offset(0, 1)
	    S2 = ActiveCell.Offset(0, 4)
	    Sheets(2).Range("A2") = S1
	    Sheets(2).Range("B2") = S2

	    If HasMoreValues(counter) Then
		    yesNo = MsgBox("Do you want to continue search?", vbYesNo)
		    If yesNo = vbNo Then
			    Sheets(counter).Activate
			    Exit For
		    End If
	    Else
		    Sheets(counter).Activate
		    Exit For
	    End If
	    Sheets(counter).Activate
    End If
   Next counter
   If notFound Then
    MsgBox ("Value not found")
    Sheets(currentSheet).Activate
   End If
End Sub
Private Function HasMoreValues(ByVal sheetCounter As Integer) As Boolean
   HasMoreValues = False
   Dim str As String
   Dim lastRow As Long
   Dim lastCol As Long
   Dim rRng  As Excel.Range
   For counter = sheetCounter + 1 To sheetCount
    Sheets(counter).Activate
    lastRow = ActiveCell.SpecialCells(xlLastCell).Row
    lastCol = ActiveCell.SpecialCells(xlLastCell).Column
    For vRow = 1 To lastRow
	    For vCol = 1 To lastCol
		    str = Sheets(counter).Cells(vRow, vCol).Text
		    If InStr(1, StrConv(str, vbLowerCase), datatoFind) Then
			    HasMoreValues = True
			    Exit For
		    End If
	    Next vCol
	    If HasMoreValues Then
		    Exit For
	    End If
    Next vRow
    If HasMoreValues Then
	    Sheets(sheetCounter).Activate
	    Exit For
    End If
   Next counter
End Function 

 

    If InStr(1, StrConv(ActiveCell.Value, vbLowerCase), datatoFind) Then
	    notFound = False
	    S1 = ActiveCell.Offset(0, 1)
	    S2 = ActiveCell.Offset(0, 4)
	    Sheets(2).Range("A2") = S1
	    Sheets(2).Range("B2") = S2' i steden for Range("b2") må den settes i neste tomme celle en til høyre. så for hver gang den setter verdien i ark 2. setter den da verdien av S2 i neste tomme celle.

 

Bare si i fra hvis mere innformasjon trengs

 

Hilsen

 

Torbjørn

[Bigelk]

Hei.

 

Tror jeg løste det problemet

 

If InStr(1, StrConv(ActiveCell.Value, vbLowerCase), datatoFind) Then
		notFound = False
		S1 = ActiveCell.Offset(0, 1)
		S2 = ActiveCell.Offset(0, 4)
		Sheets(2).Range("A2") = S1
		Sheets(2).Select
		Range("a2").Select
		Do Until ActiveCell = ""
			ActiveCell.Offset(0, 1).Select
		Loop
		ActiveCell = S2

Men det dukket opp et nytt problem.

Noen ganger finner den samme verdien flere ganger.

 

Hvis noen vet om en enklere/bedre kode for og få dette til og fungere er det bare å si i fra

 

Hilsen

 

Torbjørn

Endret 29. mars 2012 av Bigelk

[Bigelk]

Hei igjen..

 

Da ser det ut til at det er løst.

 

Fjernet denne dellen av koden

If HasMoreValues(counter) Then
yesNo = MsgBox("Do you want to continue search?", vbYesNo)
If yesNo = vbNo Then
Sheets(counter).Activate
Exit For
End If
Else
Sheets(counter).Activate
Exit For
End If
Sheets(counter).Activate
End If

 

Setter den ikke som løst helt enda, i tilfelle noen har en annen måte og løse det på, eller noen innspill.

 

 

Hilsen

 

Torbjørn

Endret 29. mars 2012 av Bigelk