Access - Ερωτήσεις / Απαντήσεις Access + VBA... Εδώ δεν υπάρχουν όρια! |
![]() |
| Εργαλεία Θεμάτων | Τρόποι εμφάνισης |
#1
| |||
| |||
![]()
Καλησπέρα σε όλη την ομάδα, Θα ήθελα την βοήθειά σας για το εξής : Έχω έναν πίνακα με ονομασία Data_Result και ένα πεδίο Data. Στο πεδίο Data υπάρχουν διάφοροι αλφαριθμητικοί χαρακτήρες. Αυτο που θέλω είναι ένα ερώτημα που να εντοπίζεται η θέση ενός 4ψήφιου αριθμού που υπάρχει πάντα (σε ακαθόριστη όμως θέση μεταξύ των εγγραφών και που δεν είναι πάντα ο ίδιος αριθμός) προκειμένου μετά να διαχωρίζω τι προηγείται, την τιμή του 4ψήφιου αριθμού αυτου αλλά και το κείμενο που ακολουθεί. Μπορεί να με βοηθήσει κάποιος; Ευχαριστώ εκ των προτέρων Γρηγόρης |
#2
| |||
| |||
![]()
Βάλε αυτό σε μια λειτουργική μονάδα και δες αν σου κανει 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
| |||
| |||
![]()
χαιρετω τα μελη στον πινακα σου προσθεσε 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]![πριν];" Επισυναπτω και το αρχειο |
#4
| |||
| |||
![]()
επειδη διαπιστωσα οτι οταν εχει πολλες τιμες επαναλαμβανει τις εγγραφες με αποτελεσμα να αργει δημιούργησα μια νεα εκδοση ισως και για εμενα να την εχω στο αρχειο μου. Πρεπει να προσθεσεις τα παρακατω πεδια στον πινακα σου Nai, DataClone, thesi, before, ari8moi, after εαν τα εχεις προσαρμοσετα στην εφαρμογη σου. Επειδη οταν δεν υπαρχουν εγγραφες για επεξεργασια ο κωδικας κτυπαει προσθεσε το παρακατω μετα τον τιτλο Private Sub Εντολή2_Click() On Error GoTo keno_Err keno_Exit: GoTo 100 keno_Err: Exit Sub 100: ................. Τελευταία επεξεργασία από το χρήστη pakos : 08-03-24 στις 21:11. |
#5
| |||
| |||
![]()
Καλημέρα, Ευχαριστώ πολύ για την συνδρομή σας. Θα δοκιμάσω τις προτεινόμενες λύσεις και εάν έχω πρόβλημα θα σας πω Γρηγόρης |
#6
| |||
| |||
![]()
καλημερα σου προτεινω την 2η μου λυση (4 ψηφιο αριθμο σε πεδιο) γιατι επιλεγει απο τιν πινακα ποσες εγγραφες δεν τακτοποιηθηκαν απο 1 εως οσες εχεις τα αποτελεσματα τα εχεις στον πινακα και δεν χρειαζεσαι ερωτημα με λιγοτερες εγγραφες ειναι πιο γρηγορο καλη συνεχεια |
![]() |
« Προηγούμενο Θέμα
|
Επόμενο Θέμα »
Εργαλεία Θεμάτων | |
Τρόποι εμφάνισης | |
| |
| ||||
Θέμα | Δημιουργός | 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.