PDA

View Full Version : Solved: User Input - Amend A List



Hoopsah
10-09-2008, 03:33 AM
Hi,

I have utilised the code below from a previous spreadsheet, however, I can only make it copy one cell across s it was previously designed to do.

I have a user input screen, where data will be entered into cells G10, G13, G16 & G19. I want it to read the info and do the same thing to it as the original coding (Checks for a duplicate, and adds it to the list) however I can only copy cell G10 so far.

ption Explicit
Const wsNAME As String = "Employee_Data"
Const wsSTART As String = "Create New FTE"
Const strRngCheck As String = "A:A"
Sub Create_New_FTE_Data()
Dim ws As Worksheet, NewRow As Long, rngFind As Range, varVal As Variant, rngData As Range
Set ws = ThisWorkbook.Sheets(wsNAME)
Set rngData = ThisWorkbook.Sheets(wsSTART).Range("G10")
If Len(rngData.Value) = 0 Then
MsgBox "You must enter a value!", vbExclamation, "ERROR!"
Exit Sub
End If
varVal = rngData.Value
Call ToggleEvents(False)
Set rngFind = ws.Range(strRngCheck).Find(what:=varVal, lookat:=xlPart, MatchCase:=False)
If rngFind Is Nothing Then
'match not found
NewRow = ws.Cells(ws.Rows.Count, Split(strRngCheck, ":")(0)).End(xlUp).Row + 1
ws.Range(Split(strRngCheck, ":")(0) & NewRow).Value = varVal
rngData.Value = "" 'if unmerged, use Clearcontents instead
rngData.Select
MsgBox "'" & varVal & "' added to the list!", vbInformation, "New Employee Added To List"
Else
'match found
rngData.Value = "" 'if unmerged, use Clearcontents instead
rngData.Select
MsgBox "A duplicate entry! Try again.", vbInformation, "ERROR!"
End If
Call ToggleEvents(True)
Application.ScreenUpdating = False
Sheets("Employee_Data").Select
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("Create New FTE").Select
Application.ScreenUpdating = True
End Sub

Public Sub ToggleEvents(blnState As Boolean)
With Application
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState Then .CutCopyMode = False
If blnState Then .StatusBar = False
End With
End Sub


The sheet it will copy it to is called "Employee_Data" and has headings at A1 - E1

I will include both pages of the spreadsheet so far, as usual thanks for any help.

As usual any help will be appreciated.

Bob Phillips
10-09-2008, 04:26 AM
Option Explicit

Const wsNAME As String = "Employee_Data"
Const wsSTART As String = "Create New FTE"
Const strRngCheck As String = "A:A"

Sub Create_New_FTE_Data()
Dim ws As Worksheet, NewRow As Long, varVal As Variant
Dim rngFind As Range
Dim rngData As Range
Dim rngCheck As Range

With ThisWorkbook

Set ws = .Worksheets(wsNAME)
Set rngData = .Worksheets(wsSTART).Range("G10")
Set rngCheck = .Worksheets(wsSTART).Range(strRngCheck)

If Len(rngData.Value) = 0 Then

MsgBox "You must enter a value!", vbExclamation, "ERROR!"
Application.ScreenUpdating = True
Exit Sub
End If

varVal = rngData.Value
Call ToggleEvents(False)
Set rngFind = ws.Range(strRngCheck).Find(what:=varVal, lookat:=xlWhole, MatchCase:=False)
If rngFind Is Nothing Then

'match not found
NewRow = ws.Cells(ws.Rows.Count, Split(strRngCheck, ":")(0)).End(xlUp).Row + 1
ws.Cells(NewRow, rngCheck.Column).Value = varVal
ws.Cells(NewRow, rngCheck.Column + 1).Value = .Worksheets(wsSTART).Range("G13")
ws.Cells(NewRow, rngCheck.Column + 2).Value = .Worksheets(wsSTART).Range("G16")
ws.Cells(NewRow, rngCheck.Column + 3).Value = .Worksheets(wsSTART).Range("G19")
rngData.Value = "" 'if unmerged, use Clearcontents instead
rngData.Select
MsgBox "'" & varVal & "' added to the list!", vbInformation, "New Employee Added To List"

Call ToggleEvents(True)
Application.ScreenUpdating = False
ws.Columns("A:A").Resize(, 4).Sort _
Key1:=ws.Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Else
'match found
rngData.Value = "" 'if unmerged, use Clearcontents instead
rngData.Select
MsgBox "A duplicate entry! Try again.", vbInformation, "ERROR!"
End If
Application.ScreenUpdating = True
End With
End Sub

Public Sub ToggleEvents(blnState As Boolean)
'Originally written by firefytr
With Application
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState Then .CutCopyMode = False
If blnState Then .StatusBar = False
End With
End Sub

Hoopsah
10-09-2008, 04:45 AM
Magic! :wizard:

Thanks again Bob - this now does exactly what I was looking for.

Cheers again

Gerry