Έχω αντιγράψει το VBA για την αντιγραφή δεδομένων από το κελί στην ίδια σειρά διαφορετική στήλη και το άλλαξα έτσι ώστε να μπορώ να αλλάξω ένα κελί στη στήλη F και να αποθηκεύσω την τιμή στη στήλη Ε, αλλά όταν το δοκιμάζω δεν συμβαίνει τίποτα. Μπορεί κάποιος να μου πει τι κάνω λάθος; Θα ήθελα επίσης να τοποθετήσω μια σφραγίδα ημερομηνίας στη στήλη G όταν κάνω την αλλαγή.
Ήλπιζα να μπορώ επίσης να κάνω το ίδιο πράγμα όταν αλλάζω ένα κελί στη Στήλη I για να το αποθηκεύσω στη Στήλη H και να σφραγίζω ημερομηνία που αλλάζει στη Στήλη J.
Οποιαδήποτε βοήθεια θα εκτιμηθεί ιδιαίτερα.
Dim xRg ως εύρος
Dim xChangeRg ως εύρος
Dim xDependRg ως εύρος
Dim xDic ως νέο λεξικό
Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)
Dim I As Long
Dim xCell ως εύρος
Dim xDCell ως εύρος
Dim xHeader ως συμβολοσειρά
Dim xCommText ως συμβολοσειρά
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Προηγούμενη τιμή :"
x = xDic.Κλειδιά
Για I = 0 To UBound(xDic.Keys)
Ορισμός xCell = Range(xDic.Keys(I))
Ορισμός xDCell = Cells(xCell.Row, 5)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
Επόμενο
Application.EnableEvents = True
Application.ScreenUpdating = True
Sub End
Ιδιωτικό δευτερεύον φύλλο εργασίας_SelectionChange(Στόχος ByVal ως εύρος)
Dim I, J As Long
Dim xRgArea ως εύρος
Στο σφάλμα GoTo Label1
Αν Target.Count > 1 Στη συνέχεια, βγείτε από το Sub
Application.EnableEvents = False
Ορίστε xDependRg = Target.Dependents
Εάν το xDependRg δεν είναι τίποτα, τότε GoTo Label1
Αν όχι το xDependRg δεν είναι τίποτα τότε
Ορισμός xDependRg = Τομή(xDependRg, εύρος ("F:F"))
End If
Ετικέτα 1:
Ορισμός xRg = Τομή (Στόχος, Εύρος ("F:F"))
Αν (Not xRg Is Nothing) Και (Not xDependRg Is Nothing) Τότε
Ορισμός xChangeRg = Ένωση(xRg, xDependRg)
ElseIf (xRg Is Nothing) and (Not xDependRg Is Nothing) Τότε
Ορίστε xChangeRg = xDependRg
ElseIf (Not xRg is Nothing) and (xDependRg Is Nothing) Τότε
Ορίστε xChangeRg = xRg
Αλλού
Application.EnableEvents = True
Έξοδος Sub
End If
xDic.RemoveAll
Για I = 1 To xChangeRg.Areas.Count
Ορισμός xRgArea = xChangeRg.Areas(I)
Για J = 1 Προς xRgArea.Count
xDic.Add xRgArea(J).Διεύθυνση, xRgArea(J).Τύπος
Επόμενο
Επόμενο
Ορισμός xChangeRg = Τίποτα
Ορισμός xRg = Τίποτα
Ορίστε xDependRg = Τίποτα
Application.EnableEvents = True
Sub End
Ήλπιζα να μπορώ επίσης να κάνω το ίδιο πράγμα όταν αλλάζω ένα κελί στη Στήλη I για να το αποθηκεύσω στη Στήλη H και να σφραγίζω ημερομηνία που αλλάζει στη Στήλη J.
Οποιαδήποτε βοήθεια θα εκτιμηθεί ιδιαίτερα.
Dim xRg ως εύρος
Dim xChangeRg ως εύρος
Dim xDependRg ως εύρος
Dim xDic ως νέο λεξικό
Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)
Dim I As Long
Dim xCell ως εύρος
Dim xDCell ως εύρος
Dim xHeader ως συμβολοσειρά
Dim xCommText ως συμβολοσειρά
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Προηγούμενη τιμή :"
x = xDic.Κλειδιά
Για I = 0 To UBound(xDic.Keys)
Ορισμός xCell = Range(xDic.Keys(I))
Ορισμός xDCell = Cells(xCell.Row, 5)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
Επόμενο
Application.EnableEvents = True
Application.ScreenUpdating = True
Sub End
Ιδιωτικό δευτερεύον φύλλο εργασίας_SelectionChange(Στόχος ByVal ως εύρος)
Dim I, J As Long
Dim xRgArea ως εύρος
Στο σφάλμα GoTo Label1
Αν Target.Count > 1 Στη συνέχεια, βγείτε από το Sub
Application.EnableEvents = False
Ορίστε xDependRg = Target.Dependents
Εάν το xDependRg δεν είναι τίποτα, τότε GoTo Label1
Αν όχι το xDependRg δεν είναι τίποτα τότε
Ορισμός xDependRg = Τομή(xDependRg, εύρος ("F:F"))
End If
Ετικέτα 1:
Ορισμός xRg = Τομή (Στόχος, Εύρος ("F:F"))
Αν (Not xRg Is Nothing) Και (Not xDependRg Is Nothing) Τότε
Ορισμός xChangeRg = Ένωση(xRg, xDependRg)
ElseIf (xRg Is Nothing) and (Not xDependRg Is Nothing) Τότε
Ορίστε xChangeRg = xDependRg
ElseIf (Not xRg is Nothing) and (xDependRg Is Nothing) Τότε
Ορίστε xChangeRg = xRg
Αλλού
Application.EnableEvents = True
Έξοδος Sub
End If
xDic.RemoveAll
Για I = 1 To xChangeRg.Areas.Count
Ορισμός xRgArea = xChangeRg.Areas(I)
Για J = 1 Προς xRgArea.Count
xDic.Add xRgArea(J).Διεύθυνση, xRgArea(J).Τύπος
Επόμενο
Επόμενο
Ορισμός xChangeRg = Τίποτα
Ορισμός xRg = Τίποτα
Ορίστε xDependRg = Τίποτα
Application.EnableEvents = True
Sub End