Ανανέωση ιστοσελίδας
ms-office.gr > Forum > Microsoft Access > Access - Ερωτήσεις / Απαντήσεις > [ Ερωτήματα ] Εντοπισμός Θέσης Αριθμού

Access - Ερωτήσεις / Απαντήσεις Access + VBA... Εδώ δεν υπάρχουν όρια!

Απάντηση στο θέμα

 

Εργαλεία Θεμάτων Τρόποι εμφάνισης
  #1  
Παλιά 06-03-24, 15:06
Όνομα: Γρηγόρης
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2013
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 20-03-2013
Μηνύματα: 131
Προεπιλογή Εντοπισμός Θέσης Αριθμού

Καλησπέρα σε όλη την ομάδα,

Θα ήθελα την βοήθειά σας για το εξής :

Έχω έναν πίνακα με ονομασία Data_Result και ένα πεδίο Data.

Στο πεδίο Data υπάρχουν διάφοροι αλφαριθμητικοί χαρακτήρες. Αυτο που θέλω είναι ένα ερώτημα που να εντοπίζεται η θέση ενός 4ψήφιου αριθμού που υπάρχει πάντα (σε ακαθόριστη όμως θέση μεταξύ των εγγραφών και που δεν είναι πάντα ο ίδιος αριθμός) προκειμένου μετά να διαχωρίζω τι προηγείται, την τιμή του 4ψήφιου αριθμού αυτου αλλά και το κείμενο που ακολουθεί.

Μπορεί να με βοηθήσει κάποιος;

Ευχαριστώ εκ των προτέρων

Γρηγόρης
Απάντηση με παράθεση
  #2  
Παλιά 07-03-24, 07:47
Όνομα: Χρήστος
Έκδοση λογισμικού Office: Ms-Office 365
Γλώσσα λογισμικού Office: Αγγλική
 
Εγγραφή: 18-11-2012
Περιοχή: Deutschland
Μηνύματα: 206
Προεπιλογή

Βάλε αυτό σε μια λειτουργική μονάδα και δες αν σου κανει

Function FindNumbers()
Dim Db As DAO.Database
Dim rs As DAO.Recordset
Dim pattern As String
Dim item As String
Dim matches As Object
Dim match As Object
Dim number As String
Dim index As Integer
Dim querySQL As String
Dim m As Object ' Declare loop variable

Set Db = CurrentDb
Set rs = Db.OpenRecordset("Data_Result")

pattern = "\d{4}" ' Regular expression pattern to match 4-digit numbers

' Check if the temporary table exists, if not create it
If Not DoesTableExist("TempSearchResults") Then
Db.Execute "CREATE TABLE TempSearchResults (TextBefore TEXT, NumberValue TEXT, TextAfter TEXT)"
End If

' Clear existing records from the temporary table
Db.Execute "DELETE FROM TempSearchResults"

rs.MoveFirst
Do Until rs.EOF
item = rs("Data")

Set matches = CreateObject("VBScript.RegExp")
matches.Global = True
matches.IgnoreCase = True
matches.pattern = pattern

Set match = matches.Execute(item)
If match.Count > 0 Then
For Each m In match
number = m.Value
index = InStr(item, number)
' Insert the result into the temporary table
Db.Execute "INSERT INTO TempSearchResults (TextBefore, NumberValue, TextAfter) VALUES ('" & Left(item, index - 1) & "', '" & number & "', '" & Mid(item, index + Len(number)) & "')"
Next m
End If

rs.MoveNext
Loop

rs.Close
Set rs = Nothing

' Create a query SQL to select from the temporary table
querySQL = "SELECT * FROM TempSearchResults"

' Open a recordset based on the query SQL
Set rs = Db.OpenRecordset(querySQL)

' Release resources
Set Db = Nothing
Set rs = Nothing
End Function
Function DoesTableExist(strTblName As String) As Boolean
On Error Resume Next
Dim Db As DAO.Database
Set Db = CurrentDb()
Dim Tbl As DAO.TableDef
Set Tbl = Db.TableDefs(strTblName)
If Err.number = 3265 Then
DoesTableExist = False
Exit Function
End If
DoesTableExist = True
End Function
Απάντηση με παράθεση
  #3  
Παλιά 07-03-24, 10:31
Όνομα: Πάκος
Έκδοση λογισμικού Office: Ms-Office 2016
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 17-12-2011
Περιοχή: Θεσσαλονικη
Μηνύματα: 169
Προεπιλογή συνεχεια

χαιρετω τα μελη

στον πινακα σου προσθεσε 3 πεδια

ari8moi => Αριθμός
thesi => Αριθμός
Nai => Σύντομο κείμενο


Εαν εχεις Function TableExist καλως αλλιως το παρακατω

Public Function TableExist(strTableName As String) As Boolean
Dim db As DAO.Database
Dim td As DAO.TableDef
Set db = CurrentDb
On Error Resume Next
Set td = db.TableDefs(strTableName)
TableExist = (Err.number = 0)
Err.Clear
End Function

Σε μια κενη φορμα εβαλα ενα κουμπι σε διαδικασια συμβαντος με το κλικ

Private Sub Εντολή2_Click()

If TableExist("Data_Result2") = True Then
DoCmd.RunSQL "DELETE Data_Result2.Data " & _
" FROM Data_Result2;"
Else
DoCmd.CopyObject , "Data_Result2", acTable, "Data_Result"
DoCmd.RunSQL "DELETE Data_Result2.Data " & _
" FROM Data_Result2;"
End If





Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim pattern As String
Dim item As String
Dim matches As Object
Dim match As Object
Dim number As String
Dim index As Integer
Dim result As String
Dim m As Object ' Declare loop variable

Set db = CurrentDb
Set rs = db.OpenRecordset("Data_Result")

pattern = "\d{4}" ' Regular expression pattern to match 4-digit numbers

rs.MoveFirst
Do Until rs.EOF
item = rs("Data")


Set matches = CreateObject("VBScript.RegExp")
matches.Global = True
matches.IgnoreCase = True
matches.pattern = pattern

Set match = matches.Execute(item)
If match.Count > 0 Then
For Each m In match
number = m.Value
index = InStr(item, number)

rs.AddNew
rs![Data] = item
rs![Nai] = "ναι"
rs![ari8moi] = number
rs![thesi] = index
rs.Update
Next m
End If

rs.MoveNext
Loop

rs.Close
Set rs = Nothing
Set db = Nothing

DoCmd.RunSQL "INSERT INTO Data_Result2 ( Data, ari8moi, thesi ) " & _
" SELECT Data_Result.Data, Data_Result.ari8moi, Data_Result.thesi " & _
" FROM Data_Result " & _
" WHERE (((Data_Result.Nai)=""ναι""));"

DoCmd.RunSQL "DELETE Data_Result.Data, Data_Result.ari8moi, Data_Result.thesi, Data_Result.Nai " & _
" FROM Data_Result " & _
" WHERE (((Data_Result.Nai)=""ναι""));"

DoCmd.RunSQL "UPDATE Data_Result2 LEFT JOIN Data_Result ON Data_Result2.Data = Data_Result.Data SET Data_Result.ari8moi = [Data_Result2]![ari8moi], Data_Result.thesi = [Data_Result2]![thesi];"


DoCmd.DeleteObject acTable, "Data_Result2"
End Sub


Οποτε στον πινακα σου εχεις το ζητουμενο και δεν χρειαζεσαι το ερωτημα
μπορεις με την instr στα πεδια του πινακα σου να επιλεξεις πριν και μετα την εγγραφη τα δεδομενα και να τα προσαρμοσεις μεσα στον κωδικα
rs![πριν] =left(item, InStr(1, item, number)-1)

Θεωρειτε βεβαιο οτι το πεδιο [πριν] υπαρχει στον πινακα σου αλλιως το προσθετεις
Βεβαια θα πρεπει να προσαρμοσεις και τους κωδικες
DoCmd.RunSQL "INSERT INTO Data_Result2 ( Data, ari8moi, thesi, πριν ) " & _
" SELECT Data_Result.Data, Data_Result.ari8moi, Data_Result.thesi, Data_Result.πριν " & _
" FROM Data_Result " & _
" WHERE (((Data_Result.Nai)=""ναι""));"

DoCmd.RunSQL "UPDATE Data_Result2 LEFT JOIN Data_Result ON Data_Result2.Data = Data_Result.Data SET Data_Result.ari8moi = [Data_Result2]![ari8moi], Data_Result.thesi = [Data_Result2]![thesi], Data_Result.πριν= [Data_Result2]![πριν];"


Επισυναπτω και το αρχειο
Συνημμένα Αρχεία
Τύπος Αρχείου: zip Database1.zip (307,6 KB, 2 εμφανίσεις)
Απάντηση με παράθεση
  #4  
Παλιά 07-03-24, 17:28
Όνομα: Πάκος
Έκδοση λογισμικού Office: Ms-Office 2016
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 17-12-2011
Περιοχή: Θεσσαλονικη
Μηνύματα: 169
Προεπιλογή συνεχεια 2

επειδη διαπιστωσα οτι οταν εχει πολλες τιμες επαναλαμβανει τις εγγραφες με αποτελεσμα να αργει δημιούργησα μια νεα εκδοση ισως και για εμενα να την εχω στο αρχειο μου.

Πρεπει να προσθεσεις τα παρακατω πεδια στον πινακα σου

Nai, DataClone, thesi, before, ari8moi, after

εαν τα εχεις προσαρμοσετα στην εφαρμογη σου.

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

Private Sub Εντολή2_Click()

On Error GoTo keno_Err
keno_Exit:
GoTo 100
keno_Err:
Exit Sub

100:
.................
Συνημμένα Αρχεία
Τύπος Αρχείου: zip 4ψηφιο αριθμο σε πεδιο.zip (32,9 KB, 3 εμφανίσεις)

Τελευταία επεξεργασία από το χρήστη pakos : 08-03-24 στις 21:11.
Απάντηση με παράθεση
  #5  
Παλιά 09-03-24, 10:09
Όνομα: Γρηγόρης
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2013
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 20-03-2013
Μηνύματα: 131
Προεπιλογή

Καλημέρα,

Ευχαριστώ πολύ για την συνδρομή σας.

Θα δοκιμάσω τις προτεινόμενες λύσεις και εάν έχω πρόβλημα θα σας πω

Γρηγόρης
Απάντηση με παράθεση
  #6  
Παλιά 09-03-24, 11:20
Όνομα: Πάκος
Έκδοση λογισμικού Office: Ms-Office 2016
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 17-12-2011
Περιοχή: Θεσσαλονικη
Μηνύματα: 169
Προεπιλογή συνεχεια

καλημερα σου προτεινω την 2η μου λυση (4 ψηφιο αριθμο σε πεδιο)
γιατι
επιλεγει απο τιν πινακα ποσες εγγραφες δεν τακτοποιηθηκαν απο 1 εως οσες εχεις
τα αποτελεσματα τα εχεις στον πινακα και δεν χρειαζεσαι ερωτημα
με λιγοτερες εγγραφες ειναι πιο γρηγορο

καλη συνεχεια
Απάντηση με παράθεση
Απάντηση στο θέμα

Εργαλεία Θεμάτων
Τρόποι εμφάνισης

Δικαιώματα - Επιλογές
Δε μπορείτε να δημοσιεύσετε νέα μηνύματα
Δε μπορείτε να δημοσιεύσετε απαντήσεις
Δεν μπορείτε να επισυνάψετε αρχεία
Δεν μπορείτε να επεξεργαστείτε τα μηνύματα σας

Ο κώδικας ΒΒ είναι σε λειτουργία
Τα Smilies είναι σε λειτουργία
Ο κώδικας [IMG] είναι σε λειτουργία
Ο κώδικας HTML είναι εκτός λειτουργίας
Trackbacks are εκτός λειτουργίας
Pingbacks are εκτός λειτουργίας
Refbacks are εκτός λειτουργίας


Παρόμοια Θέματα

Θέμα Δημιουργός Forum Απαντήσεις Τελευταίο Μήνυμα
[VBA] Αποθήκευση Φύλλου εργασίας με επιλογή θέσης agrbita Excel - Ερωτήσεις / Απαντήσεις 18 10-10-18 21:07
Εξαγωγή αρχείου σε μορφή pdf με επιλογή θέσης και με alarm ύπαρξης ίδιου ονόματος ΤΙΜΟΣ Access - Ερωτήσεις / Απαντήσεις 8 05-05-17 19:06
Εντοπισμός Φακέλου και *.txt Panos Mixos Access - Ερωτήσεις / Απαντήσεις 5 19-11-12 17:45
[Συναρτήσεις] ΛΙΣΤΑ - ΠΙΝΑΚΑΣ εντοπισμός εγγραφής Thanosp Excel - Ερωτήσεις / Απαντήσεις 7 06-03-12 20:22


Η ώρα είναι 17:48.