Yes - Dave, but this saves the person filling in the spreadsheet from ttyping
in their name for a bulk load into another program. On occasion there are
around 200 or so items being loaded.
That is why I would like to have this happen after they run the following...
any ideas? By the way - this is part of a job that I have inherited from a
former co-worker, so cleaning it up is also a goal of mine...
Option Explicit
Global Const fileNameColumn = 1
Global Const objNameColumn = 2
Global Const beginRow = 8
Global Const defaultDir = "K:\"
Public Function GetFileName(ByRef filenames() As String) As Boolean
Dim s As String
On Error GoTo CancelError
With UserForm1.CommonDialog1
.filename = ""
.MaxFileSize = 32000
.Filter = " Files|*.*"
.Flags = cdlOFNNoChangeDir
.initDir = defaultDir
.DialogTitle = "Select File"
.CancelError = True
.Flags = cdlOFNAllowMultiselect + cdlOFNExplorer + cdlOFNLongNames
.Action = 1
If Len(Trim(.filename)) > 0 Then
s = UCase(.filename)
s = LCase(Replace(s, defaultDir, ""))
filenames = Split(s, vbNullChar)
GetFileName = True
Exit Function
End If
End With
CancelError:
GetFileName = False
End Function
Public Function RemoveExtension(filename As String)
Dim i As Integer
Dim c As String
i = Len(filename)
c = Mid(filename, i, 1)
If InStr(1, filename, ".") Then
While i > 0 And c <> "."
i = i - 1
c = Mid(filename, i, 1)
Wend
If c = "." Then
RemoveExtension = Mid(filename, 1, i - 1)
Else
RemoveExtension = filename
End If
Else
RemoveExtension = filename
End If
End Function
Public Function FollowsBWDrawingConvention(s As String) As Boolean
Dim prefix As String
Dim suffix As String
Dim rest As String
FollowsBWDrawingConvention = False
If Len(s) < 2 Then Exit Function
prefix = UCase(Mid(s, 1, 1))
rest = Mid(s, 2)
If prefix = "B" And IsNumeric(rest) Then
FollowsBWDrawingConvention = True
Exit Function
End If
suffix = Mid(s, Len(s), 1)
rest = Mid(s, 1, Len(s) - 1)
If (Not IsNumeric(suffix)) And IsNumeric(rest) Then
FollowsBWDrawingConvention = True
Exit Function
End If
End Function
Sub GetFiles()
'inserts cleaned files (K:\) into sheet
Dim z As Integer
Range(Range("A8"), Range("K1000")).ClearContents
With Application.FileSearch
.LookIn = "K:\"
.SearchSubFolders = False
.filename = "*.*"
.Execute
For z = 1 To .FoundFiles.count
Range("A1000").End(xlUp).Offset(1, 0). _
Value = Dir(.FoundFiles(z))
Next z
End With
End Sub
Dave said:
I'd try:
Option Explicit
Function UserNameWindows() As String
UserNameWindows = Environ("USERNAME")
End Function
Sub AutoFillIn()
Dim myNames As Variant
Dim c As Range
Dim res As Variant
myNames = Array("dadunlap", "slhull", "mdringler", _
"sljackson", "ccparker", "thenry", _
"rdowling", "jslong", "mhjames", _
"lndavis", "jdscott", "jfullem", _
"alwrinch")
For Each c In Range("A8:A1000")
If c.Value = "" Then
Exit For
End If
c.Offset(0, 8).Formula = "=UserNameWindows()"
res = Application.Match(UserNameWindows, myNames, 0)
If IsNumeric(res) Then
'found it
c.Offset(0, 6).Value = "YES"
Else
c.Offset(0, 6).Value = "NO"
End If
Next c
End Sub
====
But isn't this putting the same value in those offset cells for each row?
I have a Sub that will not end? Any ideas...
[quoted text clipped - 32 lines]
