VBA macro fájl hiperhivatkozására névegyezés esetén

VBA macro fájl hiperhivatkozására névegyezés esetén
2015-08-05T16:31:57+02:00
2015-08-31T16:19:39+02:00
2022-12-02T19:31:05+01:00
PappLaszloDaniel
Sziasztok!



Erre nem találtam még megoldást:

Az Excel (MS Office 2013) egyik oszlopában fájlnevek vannak felsorolva kiterjesztés nélkül.
Azt szeretném elérni, hogy a macro futtatása közben keresse meg, hogy egy kiválasztott mappában talál-e pontosan egyező nevű fájlt, és ha igen, akkor azt a fájlt hivatkozza be a megfelelő cellába.

Csak pontos egyezés esetén kellene behivatkoznia (számsorok a fájlnevek és pdf-ek a fájlok). Ahol nem talál egyezést ott nem csinál semmit.  Illetve ismételt futtatás esetén újra elvégzi a behivatkozást.

Van bármi ötlet, javaslat??
Eddig csak olyan megoldásokat találtam, hogy kilistázza Excelbe egy mappa tartalmát és azt egyből linkeli is, de ezeket nem tudtam áthegeszteni..

Előre is köszönöm a választ!

Laci
Mutasd a teljes hozzászólást!
Szia!



Néhány sorban kellett változtatást csinálni, inkább beírom a teljes makrót.
Remélem, ez már rendben lesz.

Sub InsertFilesInFolder1() Dim sPath As String, Value As String, cl As Range, usor As Integer, StartCell As Range Dim WS As Worksheet Set WS = Sheets("Könyvelés") 'ide teszi a hivatkozást sPath = " d:\Users\PappL\Desktop\Hyperlink" Set StartCell = WS.Range("B2") ' a B1 cellában indul a hivatkozás gyártása, ha az első sor fejléc, akkor a B2 cellát írd ide. usor = WS.Range("Y" & Rows.Count).End(xlUp).Row For Each cl In WS.Range("Y2:Y" & usor) ' ha az első sor fejléc, akkor Y2-től indul és a vége addig tart, amíg adat van cl.Hyperlinks.Delete 'ez a sor törli az előző hivatkozásokat If Not IsEmpty(cl) Then Value = Dir(sPath & cl.Value & ".pdf") If Value <> "" Then StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _ sPath & Value, TextToDisplay:=cl.Value End If End If Set StartCell = StartCell.Offset(1, 0) ' a következő cella cime Next End Sub
Üdv.
Mutasd a teljes hozzászólást!

  • Hol akadtál el? Miért nem másoltad be a kódot, amivel próbálkoztál?
    Mutasd a teljes hozzászólást!
  • Szia,

    A folyamat ez lenne és eddig jutottam:

    1.) Megvannak a fájlok pdf-ként, el vannak nevezve egy számsorral.
    2.) Megvan a lista a fájlokról Excelben, mind az aktuális számsoros nevükkel, mind azzal a névvel, amire át kell őket nevezni.
    3.) Kész az a macro, ami átnevezi őket a kívánt új névre. (Két lépésben, először beolvas, majd megadjuk az új nevet Excelben, és aszerint átnevez.)

    Option Explicit Sub FileNametoExcel() Dim fnam As Variant Dim b As Integer 'counter for filname array Dim b1 As Integer 'counter for finding \ in filename Dim c As Integer 'extention marker Range("A1").Select ActiveCell.FormulaR1C1 = "Path and Filenames that had been selected to Rename" Range("A1").Select With Selection.Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 End With Columns("A:A").EntireColumn.AutoFit Range("B1").Select ActiveCell.FormulaR1C1 = "Input New Filenames Below" Range("B1").Select With Selection.Font .Name = "Arial" .FontStyle = "Bold" .Size = 10 End With Columns("B:B").EntireColumn.AutoFit fnam = Application.GetOpenFilename("all files (*.*), *.*", 1, _ "Select Files to Fill Range", "Get Data", True) If TypeName(fnam) = "Boolean" And Not (IsArray(fnam)) Then Exit Sub For b = 1 To UBound(fnam) ActiveSheet.Cells(b + 1, 1) = fnam(b) Next End Sub Sub RenameFile() Dim z As String Dim s As String Dim V As Integer Dim TotalRow As Integer TotalRow = ActiveSheet.UsedRange.Rows.Count For V = 1 To TotalRow z = Cells(V + 1, 1).Value s = Cells(V + 1, 2).Value Dim sOldPathName As String sOldPathName = z On Error Resume Next Name sOldPathName As s Next V MsgBox "Congratulations! You have successfully renamed all the files" End Sub
    4.) Megvannak az átnevezett pdf fájlok és most ezeket kéne hiperhivatkozni az Excelben a megfelelő helyekre, cellákba (több száz fájl).

    Erre a behivatkozásra, csak ezt találtam:

    Sub InsertFilesInFolder() Dim sPath As String, Value As String Dim WS As Worksheet Set WS = Sheets.Add sPath = ActiveWorkbook.Path & "" Value = Dir(sPath, &H1F) WS.Range("A1") = "Filename" Set StartCell = WS.Range("A2") Do Until Value = "" If Value = "." Or Value = ".." Then Else If GetAttr(sPath & Value) = 16 Then Else If Value <> ActiveWorkbook.Name And Value <> "~$" & ActiveWorkbook.Name Then StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _ Value, TextToDisplay:=Value Set StartCell = StartCell.Offset(1, 0) End If End If End If Value = Dir Loop End Sub

    De ez csak beolvassa annak a mappának a tartalmát, amiben maga a macrot tartalmazó Excel fájl van és azokat behivatkozza.

    Több órás Google keresés után ennyi van meg eddig, ebből próbáltam meg kiindulni, de nem sikerült érdemben tovább haladni.

    Nem tudom, hogy érdemes-e ezt megpróbálni átírni, vagy teljesen elölről kezdeni inkább?
    Mutasd a teljes hozzászólást!
  • Szia!

    Jó lenne tudni, hol tárolod a fájl neveket és azokat a cellákat, ahová be kell illeszteni a hiperhivatkozást, illetve honnan tudod, melyik mappában vannak a fájlok.

    A sub InsertFilesinFolder eljáráshelyett a következőt javaslom:

    Sub InsertFilesInFolder1() Dim sPath As String, Value As String, cl As Range Dim WS As Worksheet Set WS = Sheets(1) 'ide azt a munkalapot írod, ahová a hivatkozást szeretnéd kapni sPath = "Utvonal" & "" Set StartCell = WS.Range("cella") ' ide írod a cella címét, ahová a hivatkozás kell For Each cl In ActiveSheet.UsedRange.Columns(x) ' ide az az oszlop jön, amelyben a fájlnevek vannak If Not IsEmpty(cl) Then Value = Dir(sPath, cl.Value & ".pdf") If Value <> "" Then StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _ Value, TextToDisplay:=Value Set StartCell = StartCell.Offset(1, 0) ' a következő cella cime End If End If Next End Sub
    Ha megvan az a tartomány valahol, ahová a hivatkozásokat kell betenni - pl. az oszlop melletti cellába, akkor StartCell helyett használhatod a cikluson belül a cl.Offset(0,1) tartományt, azaz

    cl.Offset(0,1).Hyperlinks.Add Anchor:=StartCell, Address:= _ Value, TextToDisplay:=Value
    Így nincs szükség a StartCell változóra és a hozzátartozó sorokra sem.
    Ha más tartományban van, akkor abból kell venni a hivatkozás következő celláját.  

    A makró végigmegy az adott oszlopon és megnézi a megadott utvonalon levő mappában, hogy van-e a cella tartalmának megfelelő nevű pdf fájl. Ha van, akkor a megadott cellába beteszi a hivatkozást.

    Üdv.
    Mutasd a teljes hozzászólást!
  • Wow, köszönöm, nem gondoltam volna, hogy ilyen mélységű segítséget kapok itt! :) 

    Próbáltam ezt a kódot hozzáigazítani magamtól, de nem nagyon ment, szóval megpróbálom tömören összefoglalni a hiányzó infókat.

    A pilot verziónál ezek lesznek:

    Behivatkozandó fájlok elérési útvonala: d:\Users\PappL\Desktop\Hyperlink
    Excel fül, ahol a macro fut: "Könyvelés"
    Fájlok nevei Excelben: az Y oszlopban vannak kiterjesztés nélkül (kiterjesztés végül is egyszerűen hozzáadható, ha úgy egyszerűbb)
    Belinkelés: Ha nem bonyolult, akkor találat esetén ugyanazon sor B oszlopába hyperlink (ha bonyolultabb, akkor lehet az Y oszlopba is hyperlinkelni találat esetén)


    Illetve egy kérdésem lenne még a macroval kapcsolatban: Ha újból futtatom, akkor újra végig megy ugye a kódban megjelölt teljes tartományon (kvázi újra behivatkozik mindent)?
    Mutasd a teljes hozzászólást!
  • Szia!

    Az alábbi makrónak szerintem futnia kellene:

    Sub InsertFilesInFolder1() Dim sPath As String, Value As String, cl As Range, usor As Integer, StartCell As Range Dim WS As Worksheet Set WS = Sheets("Könyvelés") 'ide teszi a hivatkozást sPath = " d:\Users\PappL\Desktop\Hyperlink" Set StartCell = WS.Range("B1") ' a B1 cellában indul a hivatkozás gyártása, ha az első sor fejléc, akkor a B2 cellát írd ide. usor = WS.Range("Y" & Rows.Count).Row For Each cl In WS.Range("Y1:Y" & usor) ' ha az első sor fejléc, akkor Y2-től indul és a vége addig tart, amíg adat van cl.Hyperlinks.Delete 'ez a sor törli az előző hivatkozásokat If Not IsEmpty(cl) Then Value = Dir(sPath, cl.Value & ".pdf") If Value <> "" Then StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _ sPath & cl.Value, TextToDisplay:=Value Set StartCell = StartCell.Offset(1, 0) ' a következő cella cime End If End If Next End Sub
    Az előző hivatkozások mind törlődnek a B oszlopból. Ha nincs adat az Y oszlopban (vagy nincs olyan nevű fájl), akkor üres marad a B oszlop cellája, egyébként pedig beteszi a linket a cellába.

    Bocsi, hogy csak most válaszolok, de eléggé el voltam havazva az elmúlt pár napban.

    Üdv.
    Mutasd a teljes hozzászólást!
  • Még egy helyesbítés:

    usor=WS.Range("Y" & Rows.Count).Row helyett usor=WS.Range("Y" & Rows.Count).End(xlUp).Row Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    Bocsi, hogy csak most, szabadságon voltam. :)



    Naszóval, kipróbáltam, de ennél a résznél:

    If Value <> "" Then StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _ sPath & cl.Value, TextToDisplay:=Value
    azt írja, hogy Run-time error '13' : Type mismatch.

    Azt korábban nem tudom jeleztem-e egyértelműen, hogy a B oszlopban egy már meglévő azonosító kód van, és erre a kódra linkelném be az Y oszlop értéknek megfelelő fájlt.
    De ha ezt felülírja, vagy kitörli a már ott lévő azonosító kódot, az nem olyan nagy para.


    Előre is köszönöm, ha rá tudsz nézni!

    Szép napot!
    Mutasd a teljes hozzászólást!
  • Az nem lehet, hogy a fájlnevek hossza lehet limitáló tényező? (Olyasmibe mintha korábban már beleütköztem volna, hogy az Excel csak 15 karakterig veszi figyelembe a cella értéket.)

    Az általános formula szerint most egy fájlnév kiterjesztés nélkül 29 karakter.
    Mutasd a teljes hozzászólást!
  • Szia!

    Az sPath változó végére kell még egy backslash (\)
    Azaz:

    sPath = " d:\Users\PappL\Desktop\Hyperlink\"
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    Sajnos nem oldotta meg.
    Ugyan úgy, ennél a résznél akad el:

    If Value <> "" Then StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _ sPath & cl.Value, TextToDisplay:=Value
    Ebben amikor változtattam:

    For Each cl In WS.Range("Y2:Y" & usor)
    hogy Y helyett X-et írtam (X-ben szintén voltak adatok) akkor ugyanúgy "runtime error 13" üzenetet kaptam. Amikor Z-re írtam át (ami egy üres oszlop volt) akkor végigfutott a makró, de ugye semmi nem történt az üres cellák miatt.

    Illetve B1:Y2072 egy Táblázat (Beszúrás -> Táblázat), ez nem tudom befolyásol-e.
    Mutasd a teljes hozzászólást!
  • Szia!

    Amikor Z-re írtam át (ami egy üres oszlop volt) akkor végigfutott a makró, de ugye semmi nem történt az üres cellák miatt.

    Hiszen a feltétel miatt bele sem ment abba a részbe, ahol a hivatkozást kellett volna beszúrnia.

    Így ránézésre nem látok olyan problémát, ami miatt nem megy a dolog - a táblázat forma nem okozhatja, nekem több olyan fájlom is van, amelyben táblázatba szúrom be a hivatkozást -, más oka lehet.
    Ha feltennél egy 2-3 soros mintát, talán könnyebben megtalálhatnánk a hiba okát.

    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    Öhm, igen, jogos. :)

    Csatolva feltöltök akkor pár sort mintaként, ezt kimásoltam a nagy táblázatból.

    Üdv,
    Mutasd a teljes hozzászólást!
    Csatolt állomány
  • Szia!



    Néhány sorban kellett változtatást csinálni, inkább beírom a teljes makrót.
    Remélem, ez már rendben lesz.

    Sub InsertFilesInFolder1() Dim sPath As String, Value As String, cl As Range, usor As Integer, StartCell As Range Dim WS As Worksheet Set WS = Sheets("Könyvelés") 'ide teszi a hivatkozást sPath = " d:\Users\PappL\Desktop\Hyperlink" Set StartCell = WS.Range("B2") ' a B1 cellában indul a hivatkozás gyártása, ha az első sor fejléc, akkor a B2 cellát írd ide. usor = WS.Range("Y" & Rows.Count).End(xlUp).Row For Each cl In WS.Range("Y2:Y" & usor) ' ha az első sor fejléc, akkor Y2-től indul és a vége addig tart, amíg adat van cl.Hyperlinks.Delete 'ez a sor törli az előző hivatkozásokat If Not IsEmpty(cl) Then Value = Dir(sPath & cl.Value & ".pdf") If Value <> "" Then StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _ sPath & Value, TextToDisplay:=cl.Value End If End If Set StartCell = StartCell.Offset(1, 0) ' a következő cella cime Next End Sub
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    Úúú, köszönöm!



    No, most azt írja, hogy Run-time error 52 - Bad file name or number

    Egyszerűbb lenne, ha már az Excel Y oszlopában hozzárendelném a ".pdf" kiterjesztést is?

    Üdv,
    Mutasd a teljes hozzászólást!
  • Szia!

    Meg kellene nézned, hogy pontosan ott vannak-e ezek a fájlok, ahova az elérési út mutat.
    Ki kellene íratni az sPath változó értékét az immediate ablakban. Amikor hibával megáll, akkor debug gombot nyomj neki és az immediate ablakba írd be: ?sPath és enter.

    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia,

    No, nagy nehezen csak meglett - volt egy szóköz az idézőjel és a D: meghajtó között a kódban. :D
    Így már működik és behivatkozza őket! :)

    Nagyon köszönöm!!!!
    Mutasd a teljes hozzászólást!
Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd