Μακροεντολη για ψαξιμο συγκεκριμενων τιμων στο excel

[meim10001000]

Χρειαζομαι μια μακροεντολη σε vba η οποια (βλεπε επισυναπτομενο αρχειο) θα μου βρισκει για καθε

 

τριαδα αριστερα ποσες φορες εμφανιζεται στις πενταδες δεξια. Πχ η τριαδα 1,2,7 εμφανιζεται μια φορα, η

 

τριαδα 4,6,19 δυο φορες κτλ. Δηλαδη ετσι οπως θα ειναι οι τριαδες η μια κατω απ την αλλη στο excel διπλα

 

σε καθε μια να μου εμφανιζει ποσες φορες την βρηκε στις αντιστοιχες πενταδες δεξια.Παιδια βοηθηστε λιγο

 

θα μου βοηθησει πολυ ενας τετοιος κωδικας. Το εκανα με εντολες στο excel αλλα ειναι πολυ βαρυ και δεν

 

τρεχει. Ευχαριστω

[australis]

Το παρακατω για να δουλεψει πρεπει τα δεδομενα να ειναι τοποθετημανα οπως στη φωτο

Δηλαδη οι προς αναζητηση τιμες να ειναι στις στηλες Α,Β,C

και το ψαξιμο να γινεται απο τη στηλη G και μετα....

Ακόμα, στη πρωτη εντολη - Sheets("Sheet1").Select - βαλε το πραγματικο ονομα του sheet

 

>

Public Sub mysearch()
Dim search_for As String
sp = Separator
Sheets("Sheet1").Select
Range("A1").Select
Application.ScreenUpdating = False
If ActiveCell.Value = "" Then ActiveCell.Value = "Temporary_Entry"
Col = ActiveSheet.UsedRange.Columns.Count
Row = ActiveSheet.UsedRange.Rows.Count
If ActiveCell.Value = "Temporary_Entry" Then ActiveCell.Value = ""
For i = 1 To Row
 search_for = merge_cells(3, sp)
 chkempty = Replace(search_for, " " + sp, "")
 If chkempty <> "" Then
	 found = 0
	 Range("g1").Select
	 For j = 1 To Row
		 chk_into = merge_cells(Col - 6, sp)
		 indx = InStr(chk_into, search_for)
		 While indx > 0
			 found = found + 1
			 chk_into = Right(chk_into, Len(chk_into) + 1 - indx - Len(search_for))
			 indx = InStr(chk_into, search_for)
		 Wend
	 Next j
	 Range("D" + CStr(i)).Select
	 ActiveCell.Value = found
	 ActiveCell.Offset(1, -3).Select
 End If

Next i
Application.ScreenUpdating = True

End Sub
Public Function merge_cells(num, sp) As String
sw = ""
For k = 1 To num
 If ActiveCell.Value = "" Then sw = sw + " " Else sw = sw + CStr(ActiveCell.Value)
 sw = sw + sp
 ActiveCell.Offset(0, 1).Select
Next k
ActiveCell.Offset(1, -num).Select
merge_cells = sw
End Function
Public Function Separator()
Dim rFound As Range
i = 0
Do
 i = i + 1
 sp = Chr(i) + Chr(i)
 Set rFound = Cells.Find(What:=sp, After:=Cells(1, 1), MatchCase:=False)
 valid_sp = rFound Is Nothing or i=255
Loop Until valid_sp
Separator = sp
End Function

Επεξ/σία 25 Σεπτεμβρίου 2012 από australis