Sub BILD_1_Filter()

If MsgBox("Are You sure?", 64 + vbYesNo, "Message!") = vbYes Then

' Bild 1...................................................
On Error Resume Next
    Set rngPics = Range("A2:A10000")
    Set rngOut = Range("A2:A10000")
    rngOut.ClearComments
    For i = 1 To rngPics.Cells.Count
        If rngPics.Cells(i, 1).Value <> "" Then
            p = rngPics.Cells(i, 1).Value
            With rngOut.Cells(i, 1)
                .AddComment.Text Text:=""
                .Comment.Shape.Width = 200
                .Comment.Shape.Height = 200
                .Comment.Visible = True
                .Comment.Shape.Select True
            End With
            With rngOut.Cells(i, 1).Comment.Shape
                .Fill.UserPicture p
            End With
        End If
    Next i
    Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    

      
    End If
End Sub

Sub download()
Application.DisplayAlerts = False
    
Dim csvURL As String
    csvURL = "http://haendlerportal.sit-moebel.de/csv/verfuegbarkeit.csv"
    DownloadBinaryFile csvURL, ThisWorkbook.Path & "\BL - Lieferanten\Bestand - SIT.csv", True
        
    csvURL = "http://haendlerportal.moebilia.de/csv/verfuegbarkeit.csv"
    DownloadBinaryFile csvURL, ThisWorkbook.Path & "\BL - Lieferanten\Bestand - Mцbilia.csv", True
    
    csvURL = "http://skyport.myapix.de/export/exportListing.php?id=8236646963963"
    DownloadBinaryFile csvURL, ThisWorkbook.Path & "\BL - Lieferanten\Bestand - Skyport.csv", True
    

            If i Mod Int(iLoopCount * 0.02) = 0 Then Call UpdateProgress(i / iLoopCount)
            If bCancel Then
                MsgBox "Процесс прерван пользователем !", vbExclamation
                Exit Sub
            End If

    ProgressForm.Hide
    MsgBox "Процесс успешно завершен !", vbInformation       
End Sub

Private Sub UpdateProgress(Pct As Double)
    With ProgressForm
        .FrameProgress.Caption = Format(Pct, "0%")
        .LabelProgress.Width = Pct * (.FrameProgress.Width - 10)
        .Repaint
    End With
End Sub

Function GetPictureSize(sPath As String, sFileName As String)
    Dim objFile As Object, sPictureSize As String, sFS As String, sLS As String
    Dim lWidth As Long, lHeight As Long
     
    Set objFile = CreateObject("Shell.Application").Namespace(CVar(sPath)).ParseName(sFileName)
    sPictureSize = objFile.ExtendedProperty("Dimensions")
    sFS = Left$(sPictureSize, 1)
    sLS = Right$(sPictureSize, 1)
 
    sPictureSize = Mid$(sPictureSize, 2, Len(sPictureSize) - 2)
    lWidth = Val(sPictureSize)
    lHeight = Val(Mid$(sPictureSize, InStr(sPictureSize, "x") + 1))
  
    GetPictureSize = Array(lWidth, lHeight)
End Function


Sub DateiInfos()
Dim objFSO         As Object
Dim objOrdner      As Object
Dim objDatei       As Object
Dim i              As Integer
Dim pic            As Picture
Dim aPicSize
'Hier Pfad anpassen
  
Const Pfad = "C:\Users\Computer\Desktop\DONT TOUCH\sit_bilder\"
  
i = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)
  
With ThisWorkbook.Worksheets("Tabelle1")

    .Range("A1:C1") = Array("Name", "Breite", "Hohe")
       
    On Error Resume Next
    For Each objDatei In objOrdner.Files
        .Cells(i, 1) = objDatei.Name
        aPicSize = GetPictureSize(Pfad, objDatei.Name)
        .Cells(i, 2) = aPicSize(0)
        .Cells(i, 3) = aPicSize(1)
        i = i + 1
    Next
    .Columns("A:C").AutoFit
End With
End Sub

.Range("A1:C1") = Array("Name", "Breite", "Hohe", "Size")

Sub DateiInfos()
Dim objFSO         As Object
Dim objOrdner      As Object
Dim objDatei       As Object
Dim i              As Integer
Dim pic            As Picture

'Hier Pfad anpassen

Const Pfad = "C:\Users\alexa\Desktop\files\BK\Hauptbilder\"

i = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)

With ThisWorkbook.Worksheets("Tabelle3")
    .Range("A1:E3000").ClearContents
    .Range("A1:C1") = Array("Name", "Breite", "Hцhe")
     
On Error Resume Next
   
    For Each objDatei In objOrdner.Files
    Set pic = .Pictures.Insert(Pfad & objDatei.Name)
        .Cells(i, 1) = objDatei.Name
        .Cells(i, 2) = pic.Width
        .Cells(i, 3) = pic.Height
        i = i + 1
    Next
    .Pictures.Delete
    .Columns("A:C").AutoFit
End With
End Sub

Sub knopki()
    Range("A1").Select
    Selection.OnAction = "juni_1"
End Sub

Range("A10").Select
    Selection.Copy
    Sheets("Quittung").Select
    Range("C4:D4").Select
    ActiveSheet.Paste
    
    Sheets("Januar").Select
    Range("B10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Quittung").Select
    Range("E9:G9").Select
    ActiveSheet.Paste
    
    Sheets("Januar").Select
    Range("C10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Quittung").Select
    Range("C6:G6").Select
    ActiveSheet.Paste
    
    Sheets("Januar").Select
    Range("D10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Quittung").Select
    Range("C7:G7").Select
    ActiveSheet.Paste

Sub druck()

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        
    
End Sub

Sub punkt()
    Range("A1").Select
    Selection.NumberFormat = "@"
    ActiveCell.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("A1").Select
End Sub

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
 
    Application.ScreenUpdating = False  'отключаем обновление экрана для скорости
     
    'вызываем диалог выбора файлов для импорта
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
 
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        Exit Sub
    End If
     
    'проходим по всем выбранным файлам
    x = 1
    While x <= UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
        Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        importWB.Close savechanges:=False
        x = x + 1
    Wend
 
    Application.ScreenUpdating = True
End Sub

Sub Selection_eXchange()

    If Not TypeName(Selection) = "Range" Then Exit Sub
    Dim tmpVar1, tmpVar2
    Dim tmpRng1 As Range, tmpRng2 As Range
    With Selection
 
        Select Case .Areas.Count
        Case 1
            If .Count = 2 Then
                Set tmpRng1 = .Cells(1): Set tmpRng2 = .Cells(2)
            ElseIf .Rows.Count = 2 And .Columns.Count > 2 Then
                Set tmpRng1 = Range(Cells(.Row, .Column), Cells(.Row, .Column + .Columns.Count - 1))
                Set tmpRng2 = tmpRng1.Offset(1, 0)
            ElseIf .Columns.Count = 2 And .Rows.Count > 2 Then
                Set tmpRng1 = Range(Cells(.Row, .Column), Cells(.Row + .Rows.Count - 1, .Column))
                Set tmpRng2 = tmpRng1.Offset(0, 1)
            Else: Exit Sub
            End If
        Case 2
            If .Areas(1).Columns.Count = .Areas(2).Columns.Count And _
                .Areas(1).Rows.Count = .Areas(2).Rows.Count Then
                Set tmpRng1 = .Areas(1): Set tmpRng2 = .Areas(2)
            End If
        Case Else: Exit Sub
        End Select
    End With
    Application.ScreenUpdating = False: Application.EnableEvents = False
    tmpVar1 = tmpRng1: tmpVar2 = tmpRng2
    tmpRng1.Value = tmpVar2: tmpRng2.Value = tmpVar1
    Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

<h2>Details - Element Case Handyh&uuml;lle iPhone 5S/5 - ION5 black carbon&nbsp;</h2>
<p>&nbsp;</p>
<p>&nbsp;</p>
<p>&nbsp;</p>
<ul>
<li><span style="font-size: 13px;">Hochwertige TPU H&uuml;lle f&uuml;r das iPhone 5S/5</span></li>
<li><span style="font-size: 13px;">Rutschfeste Oberfl&auml;che verhindert effektiv St&uuml;rze</span></li>
<li><span style="font-size: 13px;">Sto&szlig;absorbierende, verst&auml;rkte Ecken</span></li>
<li><span style="font-size: 13px;">R&uuml;ckseite aus echtem Karbon zum Schutz vor Kratzern und Schrammen</span></li>
<li><span style="font-size: 13px;">S&auml;mtliche Bedienelemente und Zug&auml;nge sind weiterhin erreichbar</span></li>
</ul>

ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".xlsx"