izaty
05-11-2009, 07:30 PM
hye all..
pls anybody help me on this... actually i wanna create an auto complete scroll bar...but, i'm stuck in combine the macro code...pls anybody help me..
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim oCol1 As Long
Dim oCol2 As Long
Dim oCol3 As Long
Dim oCol4 As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13,D15,D17,D19,D21,D23"
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("Details")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
historyWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
.Cells(nextRow, oCol).Value = myCell.Value
oCol1 = oCol + 1
.Cells(nextRow, oCol).Value = myCell.Value
oCol2 = oCol + 1
.Cells(nextRow, oCol).Value = myCell.Value
oCol3 = oCol + 1
' .Cells(nextRow, oCol).Value = myCell.Value
'oCol4 = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End Sub
*******************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
'Sub "autocompletes" data entered into column A using a source table on a different worksheet. If more than one match is
' found, the user is allowed to continue entering characters until a unique match is found. If no matches are found, the
' data is accepted as entered. ALT + Enter, Enter to force the macro to accept data as entered. The sub is triggered by
' the Enter key.
Dim cel As Range, match1 As Range, match2 As Range, rg As Range, targ As Range
'***Please adjust the next two statements before using this code!***
Set targ = Intersect(Target, Range("A:A")) 'Watch the cells in column A
Set rg = Worksheets("Source data").Range("AutoCompleteText") 'Use named range AutoCompleteText for "autocomplete" info
If targ Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Goto errhandler 'If code encounters an error, turn events back on
For Each cel In targ
If Not IsError(cel) Then
If cel <> "" And Right(cel, 1) <> Chr(10) Then
Set match1 = Nothing
Set match1 = rg.Find(cel & "*", lookat:=xlWhole, MatchCase:=False) 'Match is case insensitive
If Not match1 Is Nothing Then
Set match2 = rg.FindNext(after:=match1)
If match2.Address = match1.Address Then 'Code is fooled by identical strings in two cells
cel = match1 'Only one match found. Use it to "autocomplete" the cell
Else 'More than one match found. User must enter more data. Return to "Edit" mode
cel.Activate
Application.SendKeys ("{F2}") 'Begin editing after last character entered
End If
Else 'No matches found. Do not change entered text
End If
Else 'Strip the line feed from the end of the text string
If cel <> "" And Right(cel, 1) = Chr(10) Then cel = Left(cel, Len(cel) - 1)
End If
End If
Next cel
errhandler: Application.EnableEvents = True
On Error Goto 0
Application.ScreenUpdating = True
End Sub
or...anybody have an idea to make my scrollbar become auto complete scrollbar without put the second coding above into 1st coding above..pls help me...
pls anybody help me on this... actually i wanna create an auto complete scroll bar...but, i'm stuck in combine the macro code...pls anybody help me..
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim oCol1 As Long
Dim oCol2 As Long
Dim oCol3 As Long
Dim oCol4 As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13,D15,D17,D19,D21,D23"
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("Details")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
historyWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
.Cells(nextRow, oCol).Value = myCell.Value
oCol1 = oCol + 1
.Cells(nextRow, oCol).Value = myCell.Value
oCol2 = oCol + 1
.Cells(nextRow, oCol).Value = myCell.Value
oCol3 = oCol + 1
' .Cells(nextRow, oCol).Value = myCell.Value
'oCol4 = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End Sub
*******************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
'Sub "autocompletes" data entered into column A using a source table on a different worksheet. If more than one match is
' found, the user is allowed to continue entering characters until a unique match is found. If no matches are found, the
' data is accepted as entered. ALT + Enter, Enter to force the macro to accept data as entered. The sub is triggered by
' the Enter key.
Dim cel As Range, match1 As Range, match2 As Range, rg As Range, targ As Range
'***Please adjust the next two statements before using this code!***
Set targ = Intersect(Target, Range("A:A")) 'Watch the cells in column A
Set rg = Worksheets("Source data").Range("AutoCompleteText") 'Use named range AutoCompleteText for "autocomplete" info
If targ Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Goto errhandler 'If code encounters an error, turn events back on
For Each cel In targ
If Not IsError(cel) Then
If cel <> "" And Right(cel, 1) <> Chr(10) Then
Set match1 = Nothing
Set match1 = rg.Find(cel & "*", lookat:=xlWhole, MatchCase:=False) 'Match is case insensitive
If Not match1 Is Nothing Then
Set match2 = rg.FindNext(after:=match1)
If match2.Address = match1.Address Then 'Code is fooled by identical strings in two cells
cel = match1 'Only one match found. Use it to "autocomplete" the cell
Else 'More than one match found. User must enter more data. Return to "Edit" mode
cel.Activate
Application.SendKeys ("{F2}") 'Begin editing after last character entered
End If
Else 'No matches found. Do not change entered text
End If
Else 'Strip the line feed from the end of the text string
If cel <> "" And Right(cel, 1) = Chr(10) Then cel = Left(cel, Len(cel) - 1)
End If
End If
Next cel
errhandler: Application.EnableEvents = True
On Error Goto 0
Application.ScreenUpdating = True
End Sub
or...anybody have an idea to make my scrollbar become auto complete scrollbar without put the second coding above into 1st coding above..pls help me...