Microsoft Excel

Herbers Excel/VBA-Archiv

Hilfe beim Ändern eines Codes

Betrifft: Hilfe beim Ändern eines Codes von: Manueö
Geschrieben am: 11.09.2014 12:28:07

Hallo erst mal

Ich brauche eure Hilfe bei diesem VBA Code:

Public blnFolderFound As Boolean
Option Explicit
 
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As  _
 _
String, nSize As Long) As Long
Function gUsername() As String
Dim lngLen As Long
Dim strBuffer As String
Const dhcMaxUserName = 255
strBuffer = Space(dhcMaxUserName)
lngLen = dhcMaxUserName
   If CBool(GetUserName(strBuffer, lngLen)) Then gUsername = Left$(strBuffer, lngLen - 1)
End Function
 
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim endRow As Long
Dim rng As Range, c As Range
Dim currPath As String
 
endRow = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row ''Find end row in column C
 
Set rng = Range(Cells(1, 3), Cells(endRow, 3)) ''check each used cell in column C
 For Each c In rng '' For each cell in range
   If c.Value <> vbNullString And c.Hyperlinks.Count = 0 Then  ''test to see if cell not empty   _
_
and no hyperlink to speed loop up
 Cells(c.Row, 1).Value = Cells(c.Row, 3).Value & "_" & Cells(c.Row, 2).Value ''concatenate the   _
_
two values
 
 ''Test to see if file exists and create on if it doesn't
  currPath = ThisWorkbook.Path
  If currPath = vbNullString Then currPath = "C:\Users\" & gUsername & "\Desktop" ''save folder  _
 _
to desktop if file isn't saved
    folderExists currPath, Cells(c.Row, 1).Value
 
   ''if the folder is found, move on to the next cell to check
   If blnFolderFound = True Then GoTo nextCellToCheck
 
   ''if the folder wasn't found and one was created in the folderExists function, add a  _
hyperlink
    ActiveSheet.Hyperlinks.Add Anchor:=c, Address:=currPath & "\" & Cells(c.Row, 1).Value,  _
TextToDisplay:=c.Value
 
 
    Else: End If
    nextCellToCheck:
    blnFolderFound = False
Next c
 
Set rng = Nothing
 
 
End Sub
 
Function folderExists(s_directory As String, s_folderName As String)
Dim obj_fso As Object, obj_dir As Object, obj_folder As Object
 
Set obj_fso = CreateObject("Scripting.FileSystemObject") '' create a filesystem object
Set obj_dir = obj_fso.GetFolder(s_directory) ''create a folder object
 
 
For Each obj_folder In obj_dir.SubFolders '' for each folder in the active workbook's folder
   If obj_fso.folderExists(s_directory & "\" & s_folderName) = True Then blnFolderFound = True:  _
 _
Exit For    ''see if the file exists
Next
 
If blnFolderFound = False Then obj_fso.CreateFolder (s_directory & "\" & s_folderName) ''if it   _
_
doesn't exist create one
 
Set obj_fso = Nothing
Set obj_dir = Nothing
 
End Function
Dieser Code generiert einen Ordner aus dem Wert von Zelle C und (wenn ausgefüllt) Zelle B und schreibt in die Zelle C einen Hyperlink zum Ordner. Das ist ja eigentlich alles in Ordnung.


Nun meine Problem: Ich würde gerne die Zellen in die ich was eintragen muss und in in die der Hyperlink geschrieben wird verändern. Ich versuche dies schon eine ganze Weile aber es funktioniert einfach nicht. Könnte mir jemand sagen wo ich etwas verändern muss das zum Beispiel der Hyperlink in die Zelle F geschrieben würde?



Danke schon mal im Voraus für eure Bemühungen!!

  

Betrifft: AW: Hilfe beim Ändern eines Codes von: Rudi Maintaire
Geschrieben am: 11.09.2014 12:51:47

Hallo,
Hyperlink in F:
ActiveSheet.Hyperlinks.Add Anchor:=c.OffSet(,3)

Gruß
Rudi


  

Betrifft: AW: Hilfe beim Ändern eines Codes von: Mannuel
Geschrieben am: 11.09.2014 14:20:15

Danke für die schnelle Antwort. Es funktioniert auch wunderbar. Leider habe ich noch ein paar andere Probleme mit dem Code.

1. Wie kann ich einstellen das die ersten 6 Zeilen ausgeschlossen werden? Also dort wird dann nichts mit der Zelle C gemacht usw.

2. Dann das nächste Probleme. Bis jetzt wird ja der erste Name, also Name1_Name2, aus der Zelle C genommen. Aber es sollte aus der Zelle G genommen werden und der Name2 sollte dann aus der Zelle C genommen werden. Was müsste ich da ändern?


 

Beiträge aus den Excel-Beispielen zum Thema "Hilfe beim Ändern eines Codes"