macro en variërende bestandsnaam

[stefano]

Hallo,

Ik gebruik een macro om data van het ene sheet naar het andere te copieren. Zie hieronder.

Sub clearencopy()
Windows("pstmenu3.xls").Activate
Columns("A:C").Select
Selection.Copy
Windows("lims gesorteerd.xls").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub

Mijn probleem bestaat erin dat de bestandsnaam kan veranderen. De eerste letters zullen ALTIJD pstmenu zijn, het cijfer 3 kan veranderen van 1 tot 99. Heeft iemand een idee hoe ik deze veranderende naam kan opvangen in mijn makro ?

dbv,

Stefano

 

[jheesterbeek]

Zoiets?

Sub clearencopy()
Dim Nummer
Nummer = InputBox("Geef hieronder het betsandsnummer op", "Bestandsnummer")
Windows("pstmenu" & Nummer & ".xls").Activate
Columns("A:C").Select
Selection.Copy
Windows("lims gesorteerd.xls").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub

 

[Jan van Asseldonk]

Zonder vraagstelling als volgt:

Sub namen()
Dim i As Integer
Dim naam As String
For i = 1 To Workbooks.Count
If Left(Workbooks(i).Name, 7) = "pstmenu" Then
naam = Workbooks(i).Name
End If
Next i
Windows(naam).Activate
Columns("A:C").Copy
Windows("lims gesorteerd.xls").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub

Uitgangspunt is dat er maar één pstmenu-sheet openstaat.
Als er meerdere openstaan wordt alleen de laatste gekopieerd.

 

[stefano]

dank voor jullie antwoorden. Ik test uit ....

 

[stefano]

oplossing jheesterbeek geeft fout 9 tijdens uitvoeren : het subscript valt buiten de range.

oplossing jan van asseldonk : er gebeurt niets ... . Is een reden hiervoor de naam van de sheet ?

PS : ik wil de macro uitvoeren binnen bestand 'lims gesorteerd.xls'.

dank voor jullie reactie,

Stefano

 

[jheesterbeek]

Windows("pstmenu" & Nummer & ".xls").Activate

bovenstaande regel gaat er wel vanuit dat je de file al open hebt staan, als dat niet het geval is krijg je een fout 9.
Als je tevens wilt dat het bestand geopend wordt moet ik de code enigszins aanpassen.
Is dat je bedoeling?

 

[stefano]

Oeps , ik denk dat ik beter alles uitgebreid opgeef :

Het bestand 'lims gesorteerd.xls' bevat zes tabbladen, waarvan de eerste drie :

'Monster Types' : hier moet A:C van 'pstmenuX.xls' in gekopiëerd worden
'Testen' : hier moet A:L van 'psttestsX.xls' in gekopiëerd worden
'Info' : hier moet A:C van 'pstinfosX.xls' in gekopiëerd worden
waarin X een willekeurig getal voorstelt.

Sub namen()

Dim i As Integer
Dim j As Integer
Dim k As Integer

Dim naam1 As String
Dim naam2 As String
Dim naam3 As String

For i = 1 To Workbooks.Count
If Left(Workbooks(i).Name, 7) = "pstmenu" Then
naam1 = Workbooks(i).Name
End If
Next i
Windows(naam1).Activate
Columns("A:C").Copy
Windows("lims gesorteerd.xls").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select

For j = 1 To Workbooks.Count
If Left(Workbooks(j).Name, 8) = "psttests" Then
naam2 = Workbooks(j).Name
End If
Next j
Windows(naam2).Activate
Columns("A:L").Copy
Windows("lims gesorteerd.xls").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select

For k = 1 To Workbooks.Count
If Left(Workbooks(k).Name, 8) = "pstinfos" Then
naam3 = Workbooks(k).Name
End If
Next k
Windows(naam3).Activate
Columns("A:C").Copy
Windows("lims gesorteerd.xls").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select

End Sub

Probleem hierbij :

1. enkel de gegevens van de laatste worden gekopieerd.
2. in mijn 3 pst.....xls- bestanden is er een opmaak van de gegevens (terugloop en cellen samenvoegen). De macro loopt hier op vast.

dank bij voorbaat voor een aanpassing,

Stefano

 

[lcodee]

Stefano,

Betreft punt 2 :

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Probeer eens xlPasteAll ipv xl PasteValues dan wordt ook de opmaak meegekopieerd.

Groeten Leo

 

[Jan van Asseldonk]

Stefano,

de sheet pstmenuX.xls moet al wel geopend zijn in dezelfde Excel-sessie als 'lims gesorteerd.xls'. De code plak je in een module van 'lims gesorteerd.xls' en je start de macro 'namen' daarna vanuit je 'lims gesorteerd.xls' .

Je bestand pstmenuX.xls moet ook met kleine letters geschreven zijn.
Indien dat kan variëren gebruik dan:
If UCase(Left(Workbooks(i).Name, 7)) = "PSTMENU" Then
in plaats van:
If Left(Workbooks(i).Name, 7) = "pstmenu" Then

 

[stefano]

Oeps ,

Ik denk dat mijn 'laatste' code niet bekeken werd. Bij uitvoeren wordt slechts één van de drie tabbladen opgeviuld met waarden.

Kan je een snakijken aub ?

dbv,

Stefano

 

[stefano]

dan maar opnieuw proberen

Ik heb 4 bestanden.

alfa1.xls
beta2.xls
gamma3.xls

Daarnaast heb ik een vierde bestand totaal.xls.

Ik wil de gegevens van

het eerste tabblad van alfa1.xls kopieren naar sheetX in bestand totaal.xls
het eerste tabblad van beta2.xls kopieren naar sheetY in bestand totaal.xls
het eerste tabblad van gamma3.xls kopieren naar sheetZ in bestand totaal.xls

Met een makro lukt me dat wel, alleen is het PROBLEEM dat het cijfer van de namen van de eerste drie bestanden (alfa1, beta2 en gamma3) veranderen in functie van de tijd. bv vandaag heet het bestand alfa1.xls, morgen kan dat best alfa3.xls zijn om overmorgen opnieuw alfa1.xls te zijn idem voor de beta en de gamma.xls).

Kan iemand me helpen aub ?

dbv,

Stefano

 

[jheesterbeek]

Definieer in je macro de naam in twee delen, de tekst en het getal.
Vraag mbv een msgbox of de naam nog veranderd is. Als dit het geval is, dan vraag je het nieuwe nummer dmv een inputbox.
Je hebt nu de nieuwe naam, die je in je macro kunt gebruiken om in de formules te plaatsen.

Je kunt ook met de recorder opnemen welke code gebruikt wordt bij zoeken/vervangen (CTRL_H) en deze code gebruiken om de link naar alle aangepaste werkbladen te vervangen.

 

[stefano]

kan best

Zal best wel kloppen, maar

1. zo maar een makro uit mijn mouw schudden kan ik niet
2. liefst oplossing zonder messagebox en vraagstelling (wildcard ?)

dbv,

Stefano

 

[jheesterbeek]

staan de files in dezelfde map?
staan in deze map nog andere bestanden?

 

[stefano]

staan de files in dezelfde map?
staan in deze map nog andere bestanden?

alle bestanden staan in dezelfde map
er staan nog veel andere bestanden in die map.

Stefano

 

[jheesterbeek]

Hoe wil je dan bepalen welke file gebruikt moet worden, zonder dat je een vraag stelt?
Met een wildcard zou je dan meerdere files kunnen hebben die voldoen aan de criteria

 

[stefano]

filenaam

De filenaam beginbt altijd met het woord alfa, beta en gamma, alleen het cijfer dat volgt kan variëren.

 

[jheesterbeek]

en er staat maar één file alfa in die map?

 

[stefano]

klopt

 

[jheesterbeek]

Sub OpenEveryDirFile()

Dim strPath As String
Dim lFile As Long
Dim wkb As Workbook
Dim Source As String


Application.ScreenUpdating = False
'zoek de juiste map op
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Application.DefaultFilePath & "\"
    .Title = "Selecteer een folder"
    .Show
    If .SelectedItems.Count = 0 Then
        MsgBox ("Ophalen download-bestand gecanceled")
        Exit Sub
    Else
        strPath = .SelectedItems(1)
    End If
End With
' je kan bovenstaande (vanaf zoek de juiste map op) ook vervangen door een rechtstreekse verwijzig:
'StrPath="C:\Mapnaam\"

With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.MatchTextExactly = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() < 1 Then
MsgBox "There were no files found."
Exit Sub
End If

For lFile = 1 To .FoundFiles.Count
If Mid(.FoundFiles(lFile), Len(strPath) + 2, 4) = "Alfa" Then
    'doe hier iets met file alfa
    Set wkb = Workbooks.Open(Filename:=.FoundFiles(lFile), _
    UpdateLinks:=False, ReadOnly:=True, _
    IgnoreReadOnlyRecommended:=True)
    'doe hier iets met file 
    wkb.Close (False)
ElseIf Mid(.FoundFiles(lFile), Len(strPath) + 2, 4) = "Beta" Then
    'doe hier iets met file beta
    Set wkb = Workbooks.Open(Filename:=.FoundFiles(lFile), _
    UpdateLinks:=False, ReadOnly:=True, _
    IgnoreReadOnlyRecommended:=True)
    'doe hier iets met file 
    wkb.Close (False)
ElseIf Mid(.FoundFiles(lFile), Len(strPath) + 2, 5) = "Gamma" Then
    'doe hier iets met file Gamma
    Set wkb = Workbooks.Open(Filename:=.FoundFiles(lFile), _
    UpdateLinks:=False, ReadOnly:=True, _
    IgnoreReadOnlyRecommended:=True)
    'doe hier iets met file 
    wkb.Close (False)
End If
Next lFile
End With
Set wkb = Nothing
End Sub