Posts

Es werden Posts vom Juli, 2012 angezeigt.

Verknüpfung auf einen Ordner in anderem Ordner erstellen

Frage: Auf einen Ordner soll eine Verknüpfung erstellt werden - Diese aber in einem anderen Ordner abgelegt werden. Geht das?

Option ExplicitSub Main()Dim strTarget AsStringDim objShell AsObjectDim strPath AsStringDim strName AsStringDim objLink AsObjectDim objFSO AsObjectOnErrorGoTo Fin Set objFSO =CreateObject("Scripting.FileSystemObject")Set objShell =CreateObject("WScript.Shell") strPath ="C:\Temp\"' Dieser Ordner wird verknüpft strName ="Temp"' Das ist der Name der Verknüpfung strTarget ="E:\Excel\"' Das ist das Ziel der VerknüpfungSet objLink = objShell.CreateShortcut _(strTarget & strName &".lnk") objLink.TargetPath = strPath objLink.WorkingDirectory = strPath objLink.Save Fin:Set objLink =NothingSet objShell =NothingSet objFSO =NothingIfErr.Number <>0ThenMsgBox"Error: "&_Err.Number &" "&Err.Description EndSub

Worddatei - Tabelle - Zeilen hinzufügen

Frage: In einer Worddatei ist eine Tabelle. In dieser Tabelle möchte ich am Ende bzw. zwischendrin Zeilen einfügen - das Ganze aus Excel. Wie geht das?

Option ExplicitPublicSub Main()Dim objTable AsObjectDim objWDApp AsObjectDim objWDDoc AsObjectDim objRow AsObjectOnErrorGoTo Fin Set objWDApp = OffApp("Word")IfNot objWDApp Is NothingThenSet objWDDoc = objWDApp.Documents.Open_(ThisWorkbook.Path & Application.PathSeparator &"Doc1.doc")Set objTable = objWDDoc.Tables(1)With objTable Debug.Print.Rows.Count .Rows.Add ' Am Ende Zeile einfuegenSet objRow =.Rows.Add(BeforeRow:=.Rows(3)) Debug.Print.Rows.Count EndWithEndIfFin:Set objRow =NothingSet objTable =NothingSet objWDDoc =NothingSet objWDApp =NothingIfErr.Number <>0ThenMsgBox"Fehler: "&_Err.Number &" "&Err.Description EndSubPrivateFunction OffApp(ByVal strApp AsString)AsObjectDim objApp AsObjectOnErrorResumeNextSet objApp …

Ordner erstellen Liste in Spalte A und B - Link in Spalte C

Frage: In Spalte A und B habe ich eine fortlaufende Liste. Aus diese beiden Werten - also z. B. A1 und B1 - sollen Ordner erstellt werden. In Spalte C soll ein Link zu dem neu erstellten Ordner gelegt werden. Wie geht das?

Option Explicit Declare Function MakeSureDirectoryPathExists _ Lib "imagehlp.dll"(ByVal Pfad AsString)AsLongConst strPath AsString="C:\Temp\"' adaptPublicSub Main()Dim lngCount AsLongWith ThisWorkbook.Worksheets("Sheet1")' adaptFor lngCount =2To.Range("A"&.Rows.Count).End(xlUp).Row MakeSureDirectoryPathExists strPath &.Cells(lngCount,1).Text &_"_"&.Cells(lngCount,2).Text &"\".Hyperlinks.Add _ Anchor:=.Cells(lngCount,3),_ Address:=strPath &.Cells(lngCount,1).Text &"_"&_.Cells(lngCount,2).Text &"\",_ TextToDisplay:=.Cells(lngCount,1).Text Next lngCount EndWithEndSub
Hi…

Tabellenblatt aus allen Dateien kopieren

Frage: Aus allen Dateien eines Ordners soll das erste Tabellenblatt jeweils als neues Blatt in eine Zusammenfassung kopiert werden, wie geht das?

Option ExplicitPublicSub Main()Dim strFileName AsStringDim strPath AsStringOnErrorGoTo Fin strPath ="C:\Temp\Test\"' anpassen!!! Application.ScreenUpdating =False strFileName =Dir$(strPath &"*.xls*")IfRight(strPath,1)<>"\"Then strPath = strPath &"\"DoWhile strFileName <>""IfNot strFileName = ThisWorkbook.NameThen Workbooks.Open strPath & strFileName, ReadOnly:=TrueWith ActiveWorkbook .Worksheets(1).Copy _ After:=ThisWorkbook.Worksheets _(ThisWorkbook.Worksheets.Count).CloseFalseEndWithEndIf strFileName =Dir$()LoopFin: Application.ScreenUpdating =TrueIfErr.Number <>0ThenMsgBox"Fehler: "&_Err.Number &" "&Err.Description EndSub
Sollen auch Dateien aus Unterordn…

Alle Dateien eines Ordners - Optional mit Unterordner

Frage: Kann mir mal jemand ein Grundgerüst an die Hand geben, mit dem alle Dateien eines Ordners (optional mit Unterordner) berücksichtigt werden.

OptionExplicit' Suchmuster gegebenenfalls anpassen Const strEX AsString = "*.xls*"'-------------------------------------------------------------------------- ' Module : Module1 ' Procedure : Files_Read ' Author : Case (Ralf Stolzenburg) ' Date : 15.10.2012 ' Purpose : Alle Dateien eines Ordners - Optional mit Unterordner... '-------------------------------------------------------------------------- PublicSub Files_Read() Dim stCalc AsIntegerDim strDir AsStringDim objFSO AsObjectDim objDir AsObjectOnErrorGoTo Fin With Application .ScreenUpdating = False .AskToUpdateLinks = False .EnableEvents = False stCalc = .Calculation .Calculation = xlCalculationManual .DisplayAlerts = FalseEndWithSet objFSO = CreateObject("Scripting.FileSys…

Hyperlinks entfernen

Frage: Ich füge in eine Liste per Drag & Drop E-Mail-Adressen von einer Webseite ein. Excel macht daraus Hyperlinks, obwohl ich die Option "Internet- und Netzwerkpfade durch Hyperlinks während der Bearbeitung übernehmen" abgewählt habe. Was kann ich machen?

Vor dem Einfügen (rechte Maustaste auf den Tabellenreiter und dann "Code anzeigen" anklicken):

Option ExplicitPrivateSub Worksheet_Change(ByVal Target As Range)Me.Cells.Hyperlinks.Delete EndSub
Nach dem Einfügen für das gerade aktive Tabellenblatt (in ein Modul):

Option ExplicitSub Main() Cells.Hyperlinks.Delete EndSub

Bilder untereinander einfügen

Frage: In einem Ordner (optional mit Unterordner) sind viele Bilddateien (jpg). Diese sollen ab A1 untereinander eingefügt werden. Die Zeilenhöhe ist schon angepasst. Wie geht das?

Option ExplicitDim objPicture As Picture Dim objFSO AsObjectPublicSub Main()Dim shpShape As Shape Dim strPath AsStringOnErrorGoTo Fin strPath ="C:\Temp\Test\"IfRight(strPath,1)<>"\"Then strPath = strPath &"\" Application.ScreenUpdating =FalseWith ThisWorkbook.Worksheets(1)ForEach shpShape In .Shapes If shpShape.TopLeftCell.Column =1Then shpShape.Delete Next shpShape EndWith SearchFiles strPath,"*.jpg",False' ohne Unterordner'SearchFiles strPath, "*.jpg", True ' mit UnterordnerFin:Set objPicture =NothingSet objFSO =Nothing Application.ScreenUpdating =TrueIfErr.Number <>0ThenMsgBox"Error: "&_Err.Number &" "&Err.Description EndSubPrivateSub SearchFiles(strFold…

PowerPoint aus Excel - Format 16:9

Frage: Besteht die Möglichkeit das Seitenformat einer neu zu erstellenden PowerPoint Präsentation per VBA aus Excel heraus auf 16:9 umzustellen?

Option ExplicitConst ppSlideSizeOnScreen16x9 AsLong=15Const ppLayoutBlank AsLong=12Dim blnPPT AsBooleanDim objPP AsObjectPublicSub Main()OnErrorGoTo Fin Set objPP = OffApp("PowerPoint")IfNot objPP Is NothingThenWith objPP .Visible =True.Presentations.Add .ActivePresentation.Slides.Add 1, ppLayoutBlank .ActivePresentation.PageSetup.SlideSize = ppSlideSizeOnScreen16x9 EndWithElseMsgBox"Application not installed!"EndIfFin:MsgBox"Nach Klick wird PowerPoint wieder geschlossen!",64IfNot objPP Is NothingThenIf blnPPT =TrueThen objPP.Quit blnPPT =FalseEndIfEndIfSet objPP =NothingIfErr.Number <>0ThenMsgBox"Fehler: "&_Err.Number &" "&Err.Description EndSubPrivateFunction OffApp(ByVal strApp AsString,_ Optional b…

Datei speichern Dialog - Format

Frage: Ein Datei-Speichern-Unter-Dialog soll angezeigt werden. Mit den Möglichkeiten als "XLSM = 52" oder "XLSX = 51" zu speichern. Die verschiedenen Formate sind unten nochmal aus der VBA-Hilfe kopiert. Wenn als "XLSX = 51" gespeichert wird, werden die Makros automatisch aus der Datei entfernt. Im zweiten Code sieht man, wie das Standardspeicherformatausgegeben bzw. angepasst werden kann.

Option ExplicitPublicSub Main()Dim varFilename AsVariant ActiveSheet.Copy varFilename = Application.GetSaveAsFilename(_ fileFilter:=("Exceldateien mit Makro(*.xlsm),"&_"*.xlsm,Exceldateien ohne Makro (*.xlsx),*.xlsx"),_ InitialFileName:="Testdatei"&".xlsm")If varFilename <>FalseThen ActiveWorkbook.SaveAs varFilename,_IIf(Right(varFilename,4)="xlsm",52,51)'ActiveWorkbook.Close FalseEndSubSub Main_1()Dim lngTMP AsLong lngTMP = Application.DefaultSaveFormat MsgBox Application.Default…

Geschlossene Dateien - Range auslesen

Frage: Aus geschlossenen Exceldateien (alle eines Ordners - optional mit Unterordner) soll über VBA per Formel der Range A2:Y15 ausgelesen werden und ab Zeile 2 in einer Hauptdatei eingefügt werden. Bei erneutem ausführen des Codes sollen die alten Daten erst gelöscht werden. Ab Zeile 2, da die erste Zeile eine Überschrift enthält.

Option ExplicitConst strSheetQ AsString="Tabelle1"' DIE Tabelle wird ausgelesen"Const strSheetZ AsString="Gesamt"' Die Tabelle in DIESER DateiConst strRange AsString="A2:Y15"' Der Bereich wird ausgelesenPublicSub Files_Read()Dim stCalc AsIntegerDim strDir AsStringDim objFSO AsObjectDim objDir AsObjectOnErrorGoTo Fin With Application .ScreenUpdating =False.AskToUpdateLinks =False.EnableEvents =False stCalc =.Calculation .Calculation = xlCalculationManual .DisplayAlerts =FalseEndWithSet objFSO =CreateObject("Scripting.FileSystemObject")' Datei im gleichen Ordner wi…