25. juni 2004 - 05:32Der er
11 kommentarer og 1 løsning
Automatisk "gem som", næste filnummer.
Hej,
Jeg arbejder på en formular som bliver åbnet som skrivebeskyttet. Jeg vil meget gerne have hjælp til hvorledes det er muligt at finde det sidst benyttede filnummer, lægge een til og gemme filen under dette nye nummer (ordrenummeret).
Formularen ligger på - lad os sige: "\\server\ordrer\" og hedder f.eks. XX 6000.
Når man aktiverer den celle hvor ordrenummeret skal stå, vil jeg gerne om et popup vindue spørger til om man vil gemme formularen under dette navn (og så vise det næste ledige filnummer i den folder) og give mulighed for at tilføje en kort beskrivende tekst efter de første 10 tegn i filnavnet. F.eks. "XX 6001 Rulleskøjter.xls"
Håber at jeg har beskrevet det klart nok..?
Har forsøgt mig men kan ikke rigtig komme uden om en liste i en anden fil hvor der bliver lagt en til en række af numre og det virker lidt klodset at skulle over en ekstra fil..!?
Ja, sidst jeg lavede noget lignende brugte jeg så vidt jeg da husker noget der hed parsing af filnavnet for at finde de cifre der skulle tælles og lægges en til... Vi er udstationerede og jeg har ikke fået mine bøger med.
Jeg kigger lidt på det du henviser til og vender tilbage..
Jeg har leget lidt med det du henviste til, men der er stadigt problemet med at "læse" filnavnet og finde det navn med det højeste nummer selv om det indgår midt i filnavnet. Husker jeg rigtigt hvis det var noget med parsing? Når der sorteres i folderen står filerne i den rigtige orden, sorteret efter tallene.
AA 6234, rulleskøjter AA 6235, andemad AA 6236, kager
De første to karrakterer er altid ens og mellemrummet er der også altid sammen med 6 tallet. Det er derfor de 3 cifre efter 6 tallet som der skal sorteres på og udvælges fra for at finde næste nummer i rækken. AA 6237 skal indsættes på ordren i "D5" og så skal filen gemmes som AA 6237, "tekststreng", hvor tekststrengen indsættes fra en dialogboks.
Det kan godt være at det er nemt, men jeg synes det er svært... :-(
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("D5")) Is Nothing Then Call Gem End If End Sub
resten her sættes i et modul
Public Sub Gem() Dim Bem As String, sti As String, Nr As String, Filnavn As String sti = "C:\data\" ' ret til din sti Filnavn = Left(Worksheets("Ark1").Range("D5").Value, 7) ' ret til dit arks navn i = 5999 Nr = "AA " & i Do fundet = (Dir(sti & Filnavn & "*.xls")) snavn = Nr If fundet = "" Then svar = MsgBox("Filen eksisterer ikke" & vbCrLf _ & "Skal den gemmes under navnet. " & vbCrLf _ & sti & Filnavn & ", " & Bem & ".xls", vbYesNoCancel) If svar = vbCancel Then Exit Sub
If svar = vbNo Then Nr = FindSidste(sti) Bem = InputBox("Intast bemærkninger til filen") svar = MsgBox(" Filen gemmes så som :" & vbCrLf _ & sti & Nr & ", " & Bem & ".xls", vbOKCancel) If svar = vbOK Then ActiveWorkbook.SaveAs Filename:=sti & Nr & ", " & Bem, FileFormat:=xlNormal ' filen laves som ny med det næste nummer Else Exit Sub End If Exit Sub End If
If svar = vbYes Then Bem = InputBox("Intast bemærkninger til filen") ActiveWorkbook.SaveAs Filename:=sti & Nr & ", " & Bem, FileFormat:=xlNormal ' filen laves som ny Exit Sub End If End If
If Left(fundet, 7) = snavn Then ' tjekker om den eksisterer
svar = MsgBox("Filen eksisterer som" & vbCrLf _ & sti & fundet & vbCrLf _ & "Skal den erstattes. ?", vbYesNoCancel) If svar = vbCancel Then Exit Sub If svar = vbNo Then Nr = FindSidste(sti) Bem = InputBox("Intast bemærkninger til filen") svar = MsgBox(" Filen gemmes så som :" & vbCrLf _ & sti & Nr & ", " & Bem & ".xls", vbOKCancel) If svar = vbOK Then ActiveWorkbook.SaveAs Filename:=sti & Nr & ", " & Bem, FileFormat:=xlNormal ' filen laves som ny med det næste nummer Else Exit Sub End If Exit Sub End If
If svar = vbYes Then Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=sti & fundet, FileFormat:=xlNormal ' filen overskrives Application.DisplayAlerts = True Exit Sub End If
End If i = i + 1 Nr = "AA " & i Loop
End Sub
Public Function FindSidste(sti) As String Dim Sidste() As Variant, Old As String i = 0 Old = "" Do i = i + 1 fundet = (Dir(sti & "AA *.xls")) If Old = fundet Then Exit Do Old = fundet ReDim Preserve Sidste(i) Sheets("Ark2").Cells(i, 1) = Mid(fundet, 4, 4) ' bruger her ark2 til at finde den næste Loop myVar = Application.WorksheetFunction _ .Max(Sheets("Ark2").Range("A:A")) Sheets("Ark2").Range("A:A").Clear FindSidste = "AA " & myVar + 1 End Function
Thjaa.. det kan du nok ikke lære meget af.. :-), men måske du kan fortælle mig hvorfor denne kode ikke virker, ser ud som om der er problemer med at holde rede på hvor den er i de to ark?
Sub PO_Sidste() 'Checker navnet på sidst gemte PO og gemmer som ny. Dim Bem As String, sti As String, svar As String, PO As Object, List As Object Static Filnavn
sti = "C:\Documents and Settings\JesperM\My Documents\PO Ordrer\" Filnavn = Right(Worksheets("List").Range("B1").Value, 4) Worksheets("List").Range("A1:A999").SortSpecial _ SortMethod:=xlAscending Worksheets("List").Range("A1").Select If Worksheets("List").Range("A1").Value = "" Then Range("A1") = "EA 6000" Else Worksheets("List").Range("A1").CurrentRegion.Select Range("A1:A999").End(xlDown).Select Selection.Copy Range("B1") Range("B1") = Right(Worksheets("List").Range("B1").Value, 4) Filnavn = Range("B1") + 1 End If MsgBox "Sidst gemte PO er EA " & Range("B1")
svar = MsgBox("PO'en eksisterer ikke" & vbCrLf _ & "Skal den gemmes under navnet EA " & Filnavn & ", " & Bem & ".xls", _ vbYesNo) If svar = vbYes Then ActiveCell.Offset(1, 0) = "EA " & Filnavn Bem = InputBox("Intast bemærkninger til PO'en") ActiveWorkbook.SaveAs Filename:="EA " & Filnavn & ", " & Bem, _ FileFormat:=xlNormal Worksheets("PO_AIR").Range("D7").Value = "EA" & Filnavn Else svar = vbNo Application.DisplayAlerts = False 'ActiveWorkbook.Close Application.DisplayAlerts = True End If
Sub PO_Sidste() 'Checker navnet på sidst gemte PO og gemmer som ny. Dim Bem As String, sti As String, svar As String, PO As Object, List As Object Static Filnavn Worksheets("List").Activate ' HER VÆLGES ARKET LIST sti = "C:\Documents and Settings\JesperM\My Documents\PO Ordrer\" Filnavn = Right(Worksheets("List").Range("B1").Value, 4) Worksheets("List").Range("A1:A999").SortSpecial _ SortMethod:=xlAscending
Worksheets("List").Range("A1").Select If Worksheets("List").Range("A1").Value = "" Then Range("A1") = "EA 6000" Else Worksheets("List").Range("A1").CurrentRegion.Select Range("A1:A999").End(xlDown).Select Selection.Copy Range("B1")
' ANDET ARK SKAL AKTIVERES HER ELLERS RYGER B1 I SAMME ARK, ret til dit ark Worksheets("Ark1").Activate Range("B1") = Right(Worksheets("List").Range("B1").Value, 4) Filnavn = Range("B1") + 1 End If MsgBox "Sidst gemte PO er EA " & Range("B1")
svar = MsgBox("PO'en eksisterer ikke" & vbCrLf _ & "Skal den gemmes under navnet EA " & Filnavn & ", " & Bem & ".xls", _ vbYesNo) If svar = vbYes Then ActiveCell.Offset(1, 0) = "EA " & Filnavn Bem = InputBox("Intast bemærkninger til PO'en") ActiveWorkbook.SaveAs Filename:="EA " & Filnavn & ", " & Bem, _ FileFormat:=xlNormal Worksheets("PO_AIR").Range("D7").Value = "EA" & Filnavn Else svar = vbNo Application.DisplayAlerts = False 'ActiveWorkbook.Close Application.DisplayAlerts = True End If
Ja - det var faktisk lykkedes mig at finde ud af at arkene skal aktiveres før de kan arbejdes på. Tidligere er det lykkedes mig at gøre dette "Usynligt" for brugeren. Dette kan jeg dog ikke lige huske, det hjælper ikke at forsøge med "visible = false" for så er der det samme problem med at koden ikke vil referere til arket. Det må være muligt at arbejde på et ark der ikke er åbent eller synligt.
Har du nogen ideer? Jeg stiller gerne spørgsmålet som nyt, hvis du efterhånden gerne vil have nogle flere points...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
