open file contain

[Axel]

Hello developers!
I have a workbook with 8 different sheets and the macro below allow the
user to restore earlier backup csv-files. My question is:
Can the backup be stopped if the file don't have the right name? What am
trying to do, is to abort the backup if the filename not contain som
letters.
the sheetnames is like: "4 .3.4DC" and "6 3.4DC" and so on. So if the
user pick the 4 3.4DC csv in to the 6 3.4DC sheet, it's trouble.
Anyone now?

Private Sub BBtnOkRestore_Click()
If OptionButton1 = True Then GoTo runsubs Else GoTo exitrunsubs
runsubs:
Run ("SubsBtnOkRestore_Click")
Exit Sub
exitrunsubs:
'sett dialogparameter
UsrFrmRestore.Hide
Dim myFolder As String
Dim myFileName As Variant
Dim ExistingFolder As String
myFolder = "C:\Documents and Settings\aksel\My
Documents\restoretest"
ExistingFolder = CurDir
ChDrive myFolder
ChDir myFolder
'velg lokasjon til filer
myFileName = Application.GetOpenFilename("BHA backup files (*.csv),
*.csv")
ChDrive ExistingFolder
ChDir ExistingFolder

If myFileName = False Then
MsgBox "Feil"
Exit Sub
End If
Select Case True
Case OptionButton2
Sheet15.Select
GoTo line1
Case OptionButton3
Sheet16.Select
GoTo line1
Case OptionButton4
Sheet8.Select
GoTo line1
Case OptionButton5
Sheet9.Select
GoTo line1
Case OptionButton6
Sheet10.Select
GoTo line1
Case OptionButton7
Sheet11.Select
GoTo line1
Case OptionButton8
Sheet12.Select
GoTo line1
Case Else

MsgBox "Du har ikke tatt et valg"
Unload UsrFrmRestore
Exit Sub
End Select

line1:
Unload UsrFrmRestore
ActiveSheet.Unprotect Password:="toolpusher"
'sjekk om liste eksisterer
If Not ActiveSheet.ListObjects Is Nothing Then
'Ingenting
Else
ActiveSheet.ListObjects("Liste1").Unlist
End If
'fjern frysning
ActiveWindow.FreezePanes = False
'velg hele arket
Rows("3:300").Select
'slett alt
Selection.Delete Shift:=xlUp
Range("B4").Select
'Overføre fil
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & myFileName, Destination:=Range("A3"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 3
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 2, 2, 2, 2, 4, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Selection.QueryTable.Delete
'velg frysningspunkt på nytt
With ActiveSheet
.Rows("4:4").Select
ActiveWindow.FreezePanes = True
'lage ny liste
.ListObjects.Add(xlSrcRange, Range("B3:G203"), , xlYes).Name =
"Liste1"
'Sette riktig kolonnebredde
.Columns("A:A").ColumnWidth = 4
.Columns("B:B").ColumnWidth = 10
.Columns("C:C").ColumnWidth = 80
.Columns("D").ColumnWidth = 10
.Columns("E:E").ColumnWidth = 10
.Columns("G:G").ColumnWidth = 10
.Columns("H:H").ColumnWidth = 7
'låse opp celler
.Range("E4:G203").Locked = False
.Range("B4").Select
'beskytte ark
.Protect Password:="toolpusher", DrawingObjects:=True, _
Contents:=True, Scenarios:=True, AllowFiltering:=True
.EnableSelection = xlUnlockedCells
End With

End Sub


*** Sent via Developersdex http://www.developersdex.com ***

 

[Gleam]

Please try the code below. You may need to edit the sheet name depending on
how close the filename is to the sheet name. The code looks to see if the
sheet name appears anywhere n the file name. If it doesn't it stops.

Private Sub BBtnOkRestore_Click()
If OptionButton1 = True Then GoTo runsubs Else GoTo exitrunsubs
runsubs:
Run ("SubsBtnOkRestore_Click")
Exit Sub
exitrunsubs:
MySheet = ActiveSheet.Name
'sett dialogparameter
UsrFrmRestore.Hide
Dim myFolder As String
Dim myFileName As Variant
Dim ExistingFolder As String
myFolder = "C:\Documents and Settings\aksel\My Documents\restoretest"
ExistingFolder = CurDir
ChDrive myFolder
ChDir myFolder
'velg lokasjon til filer
myFileName = Application.GetOpenFilename("BHA backup files (*.csv),*.csv")
i1 = InStr(myFileName, MySheet)
If i1 = 0 Then
MsgBox "Filename does not contain sheet name: " & MySheet & "
Exiting."
Exit Sub
End If
ChDrive ExistingFolder

 

[Axel]

Thank you very much for your help Gleam, It's function is perfect
It worked with som changes
(The restore macro is activated from a different sheet so "MySheet" had
to go below the SheetOptions )
Aksel
''''''''''''''
Private Sub BBtnOkRestore_Click()
If OptionButton1 = True Then GoTo runsubs Else GoTo exitrunsubs
runsubs:
Run ("SubsBtnOkRestore_Click")
Exit Sub
exitrunsubs:

'sett dialogparameter
UsrFrmRestore.Hide
Dim myFolder As String
Dim myFileName As Variant
Dim ExistingFolder As String
myFolder = "C:\Documents and Settings\aksel\My
Documents\restoretest"
ExistingFolder = CurDir
ChDrive myFolder
ChDir myFolder
'velg lokasjon til filer



Select Case True
Case OptionButton2
Sheet15.Select
GoTo line1
Case OptionButton3
Sheet16.Select
GoTo line1
Case OptionButton4
Sheet8.Select
GoTo line1
Case OptionButton5
Sheet9.Select
GoTo line1
Case OptionButton6
Sheet10.Select
GoTo line1
Case OptionButton7
Sheet11.Select
GoTo line1
Case OptionButton8
Sheet12.Select
GoTo line1
Case Else

MsgBox "Du har ikke tatt et valg"
Unload UsrFrmRestore
Exit Sub
End Select

line1:
MySheet = ActiveSheet.Name
myFileName = Application.GetOpenFilename("BHA backup files
(*.csv),*.csv")
i1 = InStr(myFileName, MySheet)
If i1 = 0 Then
MsgBox "Filename does not contain sheet name: " & MySheet & "
Existing."
Exit Sub
End If

ChDrive ExistingFolder

*** Sent via Developersdex http://www.developersdex.com ***