Unique ID in sheet creeeren

Status
Niet open voor verdere reacties.
Z

zargaz

Nieuwe gebruiker
Lid geworden
25 mei 2007
Berichten
2
Ik probeer een spreadsheet aan te passen die gemaakt is door een collega (en inmiddels is vertrokken). De spreadsheet stuurt informatie naar een andere spreadsheet.

Wat ik graag zou willen is dat de huidige sheet een unique id creeert in colom D4 en dit dan doorstuurt naar CSAT Quality Data.xls als er op submit gedrukt wordt.

Het unique id mag niet vaker voorkomen in CSAT Quality Data.xls
Hieronder de code die gebruikt wordt in de sheet.

Private Sub SearchButton_Click()
Dim newscnumber As String, wb As Workbook, rownumber As Long
Application.ScreenUpdating = False
On Error GoTo ErrorChk
' obtain SOLCAT case number from the user
newscnumber = InputBox("Enter SC number")
' error checking
If newscnumber = "" Then GoTo ErrorChecking
' CSAT FB data is the database and needs to be opened. Closed file will result in error.
' wb is set to the Database
Set wb = Workbooks("CSAT Quality Data.xls")
wb.Save
rownumber = 0
' Search to see if there is a duplicate in the database
For Each cell In wb.Worksheets("Data").Range("A:A")
' duplicate is found and there if someone else is editing it, there will be a LOCK in column CT
If cell.Value = newscnumber And cell.Offset(0, 97) = "LOCK" Then
' messagebox indicates who is currently editing the audit entry
MsgBox ("Case was found but is locked for editing by " & cell.Offset(0, 98).Value & "." & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Entry is currently available only for viewing.")
ThisWorkbook.Worksheets("Form").Unprotect ("bingo")
ThisWorkbook.Worksheets("Form").Range("E1").Value = "Viewing Entry"
' get_entry function enters data from database for the queried SOLCAT number
Call get_entry(rownumber, wb)
If ThisWorkbook.Worksheets("Form").Range("D9") = Null Then ThisWorkbook.Worksheets("Form").Range("D9").Formula = "=IF(ISERROR(VLOOKUP(D10,R4:S65536,2,FALSE)),A1,VLOOKUP(D10,R4:S65536,2,FALSE))"
ThisWorkbook.Worksheets("Form").Protect ("bingo")
Exit For
' duplicate is found an no one is currently editing it
ElseIf cell.Value = newscnumber And cell.Offset(0, 97) <> "LOCK" Then
ThisWorkbook.Worksheets("Form").Unprotect ("bingo")
' get the details for this SOLCAT case number
Call get_entry(rownumber, wb)
' this formula is to obtain the Workgroup by looking up the Skill
If ThisWorkbook.Worksheets("Form").Range("D9") = Null Then ThisWorkbook.Worksheets("Form").Range("D9").Formula = "=IF(ISERROR(VLOOKUP(D10,R4:S65536,2,FALSE)),A1,VLOOKUP(D10,R4:S65536,2,FALSE))"
' ask user if they want to edit or view the audit
Let Edityesno = MsgBox("Entry found. Do you want to edit?", 4)
If Edityesno = 6 Then
' if they want to edit, put a lock on the entry and enter their userid, no blank userids allowed
cell.Offset(0, 97) = "LOCK"
Do
cell.Offset(0, 98) = InputBox("Enter userid: ")
Loop Until cell.Offset(0, 98) <> ""
' mark on Entry file whether the user is Editing or Viewing the entry
ThisWorkbook.Worksheets("Form").Range("E1").Value = "Editing Entry"
wb.Save
MsgBox ("Entry has been locked for editing.")
Else: ThisWorkbook.Worksheets("Form").Range("E1").Value = "Viewing Entry"
End If
ThisWorkbook.Worksheets("Form").Protect ("bingo")
Exit For
' no duplicates found, new entry
ElseIf cell.Value = "" Then
MsgBox ("Not Found")
ThisWorkbook.Worksheets("Form").Unprotect ("bingo")
ThisWorkbook.Worksheets("Form").Range("E1").Value = "New Entry"
ThisWorkbook.Worksheets("Form").Range("D5").Value = newscnumber
ThisWorkbook.Worksheets("Form").Range("D6:F8").Value = Null
' reset the formula for the Workgroup lookup
ThisWorkbook.Worksheets("Form").Range("D9").Formula = "=IF(ISERROR(VLOOKUP(D10,R4:S65536,2,FALSE)),A1,VLOOKUP(D10,R4:S65536,2,FALSE))"
ThisWorkbook.Worksheets("Form").Range("D10:F79").Value = Null
cell.Value = newscnumber
wb.Save
ThisWorkbook.Worksheets("Form").Protect ("bingo")
Exit For
Else:
rownumber = rownumber + 1
End If
Next
Exit Sub
ErrorChk:
MsgBox "The tools has encountered an error. Please check and see if the file CSAT Quality Data.xls is open."
ErrorChecking:
End Sub

Private Sub get_entry(rownumber, wb)
' this subroutine transfers the data from the database to the correct fields in the Entry sheet
' column A in the Entry sheet contrains the offsets needed to correctly align the columns from the database
' to the rows in the Entry sheet
Dim y As Integer, x As Integer, z As Integer
y = 0
x = 0
z = 0
Do While y < 97
ThisWorkbook.Worksheets("Form").Range("C5").Offset(x, z + 1).Value = wb.Worksheets("Data").Range("A1").Offset(rownumber, y).Value
y = y + 1
If ThisWorkbook.Worksheets("Form").Range("A5").Offset(x, 0).Value = 3 And z < 2 Then
x = x
z = z + 1
ElseIf ThisWorkbook.Worksheets("Form").Range("A5").Offset(x + 1, 0).Value = 0 Then
x = x + 2
z = 0
ElseIf ThisWorkbook.Worksheets("Form").Range("A5").Offset(x, 0).Value = 2 And z < 2 Then
x = x
z = z + 2
Else: x = x + 1
z = 0
End If
Loop
End Sub

Private Sub SubmitButton_Click()
Application.ScreenUpdating = False
Dim wb As Workbook, x As Integer, y As Integer, z As Integer, rownum As Long
On Error GoTo ErrorChk
CheckStatus = ThisWorkbook.Worksheets("Form").Range("E1").Value
Set wb = Workbooks("CSAT Quality Data.xls")
wb.Save
If CheckStatus = "Editing Entry" Or CheckStatus = "New Entry" Then
rownum = 0
Do
rownum = rownum + 1
Loop Until wb.Worksheets("Data").Range("A1").Offset(rownum, 0).Value = ThisWorkbook.Worksheets("Form").Range("D5").Value Or wb.Worksheets("Data").Range("A1").Offset(rownum, 0).Value = "" Or rownum = wb.Worksheets("Data").Range("A65536").End(xlUp).Row
y = 0
x = 0
z = 0
Do While y < 97
wb.Worksheets("Data").Range("A1").Offset(rownum, y).Value = ThisWorkbook.Worksheets("Form").Range("C5").Offset(x, z + 1).Value
y = y + 1
If ThisWorkbook.Worksheets("Form").Range("A5").Offset(x, 0).Value = 3 And z < 2 Then
x = x
z = z + 1
ElseIf ThisWorkbook.Worksheets("Form").Range("A5").Offset(x + 1, 0).Value = 0 Then
x = x + 2
z = 0
ElseIf ThisWorkbook.Worksheets("Form").Range("A5").Offset(x, 0).Value = 2 And z < 2 Then
x = x
z = z + 2
Else: x = x + 1
z = 0
End If
Loop
wb.Worksheets("Data").Range("A1").Offset(rownum, 97).Value = Null
wb.Worksheets("Data").Range("A1").Offset(rownum, 98).Value = Null
ThisWorkbook.Worksheets("Form").Unprotect ("bingo")
ThisWorkbook.Worksheets("Form").Range("E1").Value = "New Entry"
ThisWorkbook.Worksheets("Form").Range("D6:F8").Value = Null
ThisWorkbook.Worksheets("Form").Range("D8").Value = "General Enquiry"
ThisWorkbook.Worksheets("Form").Range("D9").Formula = Date
ThisWorkbook.Worksheets("Form").Range("D5").Value = Null
ThisWorkbook.Worksheets("Form").Protect ("bingo")
wb.Save
MsgBox ("Entry has been saved.")
ElseIf CheckStatus = "Viewing Entry" Then
MsgBox ("You are currently in view mode and cannot submit changes to an entry. Please search for the SC number again and make sure to enter Edit mode in order to make changes to pre-existing entry.")
End If
Exit Sub
ErrorChk:
MsgBox "The tools has encountered an error. Please check and see if the file CSAT Quality Data.xls is open."

End Sub
Klik om te vergroten...

Het probleem is dat ik absoluut geen ervaring heb met VBA en ik geen idee heb waar ik moet beginnen :(

Kan iemand mij hier misschien mee helpen?
alvast bedankt voor de reacties.
 
Gebruik "
Code: 
" en geen "[quote]" dan wordt het waarschijnlij een stuk leesbaarder
 
whoops

Code: 
Private Sub SearchButton_Click()
    Dim newscnumber As String, wb As Workbook, rownumber As Long
    Application.ScreenUpdating = False
    On Error GoTo ErrorChk
' obtain SOLCAT case number from the user
    newscnumber = InputBox("Enter SC number")
' error checking
    If newscnumber = "" Then GoTo ErrorChecking
' CSAT FB data is the database and needs to be opened. Closed file will result in error.
' wb is set to the Database
    Set wb = Workbooks("CSAT Quality Data.xls")
    wb.Save
    rownumber = 0
' Search to see if there is a duplicate in the database
    For Each cell In wb.Worksheets("Data").Range("A:A")
' duplicate is found and there if someone else is editing it, there will be a LOCK in column CT
        If cell.Value = newscnumber And cell.Offset(0, 97) = "LOCK" Then
' messagebox indicates who is currently editing the audit entry
            MsgBox ("Case was found but is locked for editing by " & cell.Offset(0, 98).Value & "." & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Entry is currently available only for viewing.")
            ThisWorkbook.Worksheets("Form").Unprotect ("bingo")
            ThisWorkbook.Worksheets("Form").Range("E1").Value = "Viewing Entry"
' get_entry function enters data from database for the queried SOLCAT number
            Call get_entry(rownumber, wb)
            If ThisWorkbook.Worksheets("Form").Range("D9") = Null Then ThisWorkbook.Worksheets("Form").Range("D9").Formula = "=IF(ISERROR(VLOOKUP(D10,R4:S65536,2,FALSE)),A1,VLOOKUP(D10,R4:S65536,2,FALSE))"
            ThisWorkbook.Worksheets("Form").Protect ("bingo")
            Exit For
' duplicate is found an no one is currently editing it
        ElseIf cell.Value = newscnumber And cell.Offset(0, 97) <> "LOCK" Then
            ThisWorkbook.Worksheets("Form").Unprotect ("bingo")
' get the details for this SOLCAT case number
            Call get_entry(rownumber, wb)
' this formula is to obtain the Workgroup by looking up the Skill
            If ThisWorkbook.Worksheets("Form").Range("D9") = Null Then ThisWorkbook.Worksheets("Form").Range("D9").Formula = "=IF(ISERROR(VLOOKUP(D10,R4:S65536,2,FALSE)),A1,VLOOKUP(D10,R4:S65536,2,FALSE))"
' ask user if they want to edit or view the audit
            Let Edityesno = MsgBox("Entry found. Do you want to edit?", 4)
            If Edityesno = 6 Then
' if they want to edit, put a lock on the entry and enter their userid, no blank userids allowed
                cell.Offset(0, 97) = "LOCK"
                Do
                cell.Offset(0, 98) = InputBox("Enter userid: ")
                Loop Until cell.Offset(0, 98) <> ""
' mark on Entry file whether the user is Editing or Viewing the entry
                ThisWorkbook.Worksheets("Form").Range("E1").Value = "Editing Entry"
                wb.Save
                MsgBox ("Entry has been locked for editing.")
            Else: ThisWorkbook.Worksheets("Form").Range("E1").Value = "Viewing Entry"
            End If
            ThisWorkbook.Worksheets("Form").Protect ("bingo")
            Exit For
' no duplicates found, new entry
        ElseIf cell.Value = "" Then
            MsgBox ("Not Found")
            ThisWorkbook.Worksheets("Form").Unprotect ("bingo")
            ThisWorkbook.Worksheets("Form").Range("E1").Value = "New Entry"
            ThisWorkbook.Worksheets("Form").Range("D5").Value = newscnumber
            ThisWorkbook.Worksheets("Form").Range("D6:F8").Value = Null
' reset the formula for the Workgroup lookup
            ThisWorkbook.Worksheets("Form").Range("D9").Formula = "=IF(ISERROR(VLOOKUP(D10,R4:S65536,2,FALSE)),A1,VLOOKUP(D10,R4:S65536,2,FALSE))"
            ThisWorkbook.Worksheets("Form").Range("D10:F79").Value = Null
            cell.Value = newscnumber
            wb.Save
            ThisWorkbook.Worksheets("Form").Protect ("bingo")
            Exit For
        Else:
            rownumber = rownumber + 1
        End If
    Next
    Exit Sub
ErrorChk:
    MsgBox "The tools has encountered an error. Please check and see if the file CSAT Quality Data.xls is open."
ErrorChecking:
End Sub

Private Sub get_entry(rownumber, wb)
' this subroutine transfers the data from the database to the correct fields in the Entry sheet
' column A in the Entry sheet contrains the offsets needed to correctly align the columns from the database
' to the rows in the Entry sheet
    Dim y As Integer, x As Integer, z As Integer
    y = 0
    x = 0
    z = 0
    Do While y < 97
        ThisWorkbook.Worksheets("Form").Range("C5").Offset(x, z + 1).Value = wb.Worksheets("Data").Range("A1").Offset(rownumber, y).Value
        y = y + 1
        If ThisWorkbook.Worksheets("Form").Range("A5").Offset(x, 0).Value = 3 And z < 2 Then
            x = x
            z = z + 1
        ElseIf ThisWorkbook.Worksheets("Form").Range("A5").Offset(x + 1, 0).Value = 0 Then
            x = x + 2
            z = 0
        ElseIf ThisWorkbook.Worksheets("Form").Range("A5").Offset(x, 0).Value = 2 And z < 2 Then
            x = x
            z = z + 2
        Else: x = x + 1
            z = 0
        End If
    Loop
End Sub

Private Sub SubmitButton_Click()
    Application.ScreenUpdating = False
    Dim wb As Workbook, x As Integer, y As Integer, z As Integer, rownum As Long
    On Error GoTo ErrorChk
    CheckStatus = ThisWorkbook.Worksheets("Form").Range("E1").Value
    Set wb = Workbooks("CSAT Quality Data.xls")
    wb.Save
    If CheckStatus = "Editing Entry" Or CheckStatus = "New Entry" Then
        rownum = 0
        Do
            rownum = rownum + 1
        Loop Until wb.Worksheets("Data").Range("A1").Offset(rownum, 0).Value = ThisWorkbook.Worksheets("Form").Range("D5").Value Or wb.Worksheets("Data").Range("A1").Offset(rownum, 0).Value = "" Or rownum = wb.Worksheets("Data").Range("A65536").End(xlUp).Row
        y = 0
        x = 0
        z = 0
        Do While y < 97
            wb.Worksheets("Data").Range("A1").Offset(rownum, y).Value = ThisWorkbook.Worksheets("Form").Range("C5").Offset(x, z + 1).Value
            y = y + 1
            If ThisWorkbook.Worksheets("Form").Range("A5").Offset(x, 0).Value = 3 And z < 2 Then
                x = x
                z = z + 1
            ElseIf ThisWorkbook.Worksheets("Form").Range("A5").Offset(x + 1, 0).Value = 0 Then
                x = x + 2
                z = 0
            ElseIf ThisWorkbook.Worksheets("Form").Range("A5").Offset(x, 0).Value = 2 And z < 2 Then
                x = x
                z = z + 2
            Else: x = x + 1
                z = 0
            End If
        Loop
        wb.Worksheets("Data").Range("A1").Offset(rownum, 97).Value = Null
        wb.Worksheets("Data").Range("A1").Offset(rownum, 98).Value = Null
        ThisWorkbook.Worksheets("Form").Unprotect ("bingo")
        ThisWorkbook.Worksheets("Form").Range("E1").Value = "New Entry"
        ThisWorkbook.Worksheets("Form").Range("D6:F8").Value = Null
        ThisWorkbook.Worksheets("Form").Range("D8").Value = "General Enquiry"
        ThisWorkbook.Worksheets("Form").Range("D9").Formula = Date
        ThisWorkbook.Worksheets("Form").Range("D5").Value = Null
        ThisWorkbook.Worksheets("Form").Protect ("bingo")
        wb.Save
        MsgBox ("Entry has been saved.")
    ElseIf CheckStatus = "Viewing Entry" Then
        MsgBox ("You are currently in view mode and cannot submit changes to an entry. Please search for the SC number again and make sure to enter Edit mode in order to make changes to pre-existing entry.")
    End If
    Exit Sub
ErrorChk:
    MsgBox "The tools has encountered an error. Please check and see if the file CSAT Quality Data.xls is open."

End Sub
 
hoi

is dat 'CS number' altijd een getal of kunnen er ook letters ingegeven worden?

kopieer eerst kolom A naar een nieuwe sheet
sorteerje kolom A (in de nieuwe sheet) zodanig dat de hoogste waarde boven in rij 1 komt te staan
om een nieuwe unieke id te krijgen neem de de bovenste waarde en tel je er 1 bij op.

zo iets kun je ook met letters doen

als je er niet uit komt geef dan even aan of het lettes of cijfers zijn

groet
 
hoi
heeft het programma nog gewerkt sinds de maker weg is?

het invoeren van nieuwe waarden gaat moelijk als het blad("Form") steeds protected is

en het wijzigen idem

ps hoe ziet het invoer blad ("Form") er uit?

groet
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan