bakerman

Zonder afwijking. Private Sub Cmd_00_Click() PI = 4 * Atn(1) T_03 = PI / 40 * (CDbl(T_00) ^ 2 - CDbl(T_01) ^ 2) / CDbl(T_02) End Sub

Een 6-tal maanden geleden is er in een ander forum een gelijkaardige vraag gepasserd en daarvoor had ik toen onderstaand bestand gemaakt. In de cellen I3 en J3 vul je de binnendiameter (in cm) end de materiaaldikte (in mm) in en dan ga je in kolom B op zoek naar de overeenkomende buitendiameter. Kolom D geeft je dan het aantal meter op de rol. @ dotchiejack Waarom eerst de waarden naar het werkblad schrijven en de uitkomst terug inlezen in de Textbox als de berekening in de code zelf kan gebeuren. antisliprol_ba.xlsx Rollengte(fancy)_ba.xlsm

With ActiveSheet For Each oShape In .Shapes If (oShape.TopLeftCell.Address = "$A$1") * (oShape.Name = "Afbeelding 18") Then MsgBox "Succes" End If Next oShape End With

Sub TestShapes2() Dim oShape As Shape, img1 As String, img2 As String With ActiveSheet For Each oShape In .Shapes If oShape.TopLeftCell.Address = "$A$1" Then img1 = oShape.AlternativeText ElseIf oShape.TopLeftCell.Address = "$C$1" Then img2 = oShape.AlternativeText End If Next oShape End With If (img1 <> vbNullString) * (img2 <> vbNullString) Then MsgBox IIf(img1 = img2, "Gelijke", "Ongelijke") & " afbeeldingen" End If End Sub Speel hier maar eens mee. Test de code in het voorbeeldbestand, sleep daarna de afbeeldingen naar andere posities, wijzig de adressen in de code en draai de code opnieuw. test vgl foto's.xlsm

Graag gedaan en bedankt voor de feedback.

Wat je kan doen is de Alternatieve tekst van beide foto's vergelijken (op voorwaarde dat deze voor elke afbeelding is ingevuld) Sub TestShapes() Dim oShape As Shape With ActiveSheet For Each oShape In .Shapes oShape.TopLeftCell.Value = oShape.AlternativeText Next oShape End With End Sub De code zet deze tekst in de linksbovencel (A1 en B1 in dit geval). Op deze manier werkt je formule wel. Voor andere oplossingen zou je toegang moeten hebben tot de metadata van de afbeelding op harde schijf.

Graag gedaan en bedankt voor de feedback.

Probeer deze dan eens. ddr_ver2.xls

Ga maar eens aan de slag met deze. ddr.xls

In het naamvak van de klantnaam zet je een validatielijst met alle klantnamen. Je zal merken dat van zodra je begint te typen de lijst automatisch naar beneden scrollt naargelang de letters die je typt. In de andere cellen zet je een Vert.Zoeken formule om de overige gegevens weer te geven. De code die je in Thisworkbook hebt staan kan je gebruiken om je factuurnummers te genereren. Dim x, cl x = -1 cl = Dir("D:\John\*") Do Until cl = "" x = x + 1 cl = Dir Loop With Blad1.Range("D25") .Value = Year(Date) & "/" & Format(IIf(x > 0, x + 1, 1), "000") End With

Je zal al zeker een extra tabblad moeten aanmaken met alle klantgegevens zodat je een klantnaam kan opzoeken en de overige gegevens kan plaatsen. Om op je tweede vraag te antwoorden, ja je moet de factuur eerst opslaan als pdf-bestand om ze vervolgens als bijlage te mailen.

Laten we hiermee beginnen. Sub Find_DLD() Dim AckTime As Integer, InfoBox As Object Dim iRow As Integer ' ROW COUNTER. Dim sSourcePath As String Dim sFileType As String Dim sFileType1 As String Dim bContinue As Boolean Dim found As Boolean, fl As Object, fld As Object bContinue = True iRow = 2 ' THE SOURCE AND DESTINATION FOLDER WITH PATH. sSourcePath = "S:" sFileType = ".dld" ' TRY WITH OTHER FILE TYPES LIKE ".pdf". sFileType1 = "prd." ' LOOP THROUGH COLUMN "B" TO PICK THE FILES. While bContinue If Len(Range("E" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK. Set InfoBox = CreateObject("WScript.Shell") AckTime = 1 Select Case InfoBox.Popup("Klaar.", AckTime, "Hieperdepiep", 0) Case 1, -1 Exit Sub End Select Else On Error Resume Next With CreateObject("scripting.filesystemobject") For Each fl In .getfolder(sSourcePath).Files If fl.Name Like sFileType1 & Range("E" & CStr(iRow)).Value & sFileType Then found = True: GoTo gevonden Next For Each fld In .getfolder(sSourcePath).subfolders For Each fl In fld.Files If fl.Name Like sFileType1 & Range("E" & CStr(iRow)).Value & sFileType Then found = True: GoTo gevonden Next Next End With gevonden: If Not found Then Range("F" & CStr(iRow)).Value = "Geen kantprogramma" Range("F" & CStr(iRow)).Font.Bold = True Else Range("F" & CStr(iRow)).Value = "Kantprogramma bestaat!" Range("F" & CStr(iRow)).Font.Bold = False End If End If iRow = iRow + 1 ' INCREMENT ROW COUNTER. Wend End Sub

Zoals gevraagd zonder voorblad en met opeenvolgende kolommen. Ook heb ik myarr gebruikt met de te kopieêren bereiken, dit om aan te tonen dat je daar willekeurige bereiken kunt plaatsen en niet alleen aansluitende cellen. Sub GenerateLists() myarr = Array("$C$1", "$C$2", "$C$3") For i = 1 To Sheets.Count If Sheets(i).Name Like "Tablijst*" Then With Sheets(i) lRow = .Range("C" & .Rows.Count).End(xlUp).Row: If lRow < 3 Then lRow = 3 lCol = .Cells(3, .Columns.Count).End(xlToLeft).Column .Range("C3", .Range("C" & lRow)).Resize(, lCol).Clear End With End If Next For i = 1 To Sheets.Count If Sheets(i).Name Like "Tablijst*" Then myRow = 3: myCol = 3: mysheet = Sheets(i).Name Else With Sheets(mysheet).Cells(myRow, myCol) .Value = Sheets(i).Name .Hyperlinks.Add Sheets(mysheet).Range(.Address), "", "'" & Sheets(i).Name & "'!A1" For j = 0 To UBound(myarr) .Offset(, j + 1) = Sheets(i).Range(myarr(j)).Value Next End With myRow = myRow + 1 If myRow Mod 33 = 0 Then myRow = 3: myCol = myCol + 4 End If Next End Sub Heb je nog verdere vragen laat maar weten.

Dit is een 'generic' model. Sub GenerateLists() With Sheets("Overzichtsblad") lRow = .Range("A" & .Rows.Count).End(xlUp).Row: If lRow < 2 Then lRow = 2 .Range("A2", .Range("A" & lRow)).Clear End With For i = 2 To Sheets.Count If Sheets(i).Name Like "Tablijst*" Then With Sheets(i) lRow = .Range("C" & .Rows.Count).End(xlUp).Row: If lRow < 3 Then lRow = 3 .Range("C3", .Range("C" & lRow)).Clear End With End If Next For i = 2 To Sheets.Count If Sheets(i).Name Like "Tablijst*" Then d = 3: mysheet = Sheets(i).Name With Sheets("Overzichtsblad").Range("A" & Rows.Count).End(xlUp).Offset(1) .Value = mysheet .Hyperlinks.Add Sheets("Overzichtsblad").Range(.Address), "", "'" & mysheet & "'!A1" End With Else With Sheets(mysheet).Cells(d, 3) .Value = Sheets(i).Name .Hyperlinks.Add Sheets(mysheet).Range(.Address), "", "'" & Sheets(i).Name & "'!A1" End With d = d + 1 End If Next End Sub Telkens je een Tablijst met verwante tabbladen toevoegt of verwijdert, of als je ergens een tabblad toevoegt of verwijdert en je draait de macro worden alle lijsten aangepast. Aangezien je sprak over 200 tabbladen heb ik als eerste blad een overzichtsblad gemaakt waarop een lijst van alle Tablijstnamen met hyperlink wordt aangemaakt zodat je direct naar een bepaalde lijst kan gaan. Je zou eventueel op elkTablijstblad in een bepaalde cel (bv. A1) een hyperlink kunnen zetten om dan terug te springen naar het overzichtsblad en op elk subtabblad een hyperlink om naar het Tablijstblad te springen. Cor-Assa.xlsm

Dit is de volledig geautomatiseerde versie. Bij deze hoef je nog enkel zoekwaardes in te brengen en de resultaten verschijnen automatisch. Als je alle zoekwaarden verwijdert wordt de merknaam kolom automatisch leeg gemaakt. Marinus_Filter_Auto.xlsm

Met formules is dit mi niet op te lossen. Andere methode met AdvancedFilter. Zoekwaarden in kolom A van blad1, Knop klikken voor filteren. Marinus_Filter.xlsm

Bedankt voor de feedback en graag gedaan.

Maak gebruik van ScreenUpdating om het vervelende trillen op je scherm tegen te gaan.

Ik heb het eerder zo begrepen. HH1963.xlsm

Ok, nieuwe poging. Bij deze zal je echter wel de layout van je zoektabel moeten wijzigen, maar de resultaten komen naast elkaar in een tabel zoals gevraagd. Marinus rev02.xlsx

Ik heb even iets in elkaar gestoken zodat je niet met lege handen staat, Het is niet de tabelvorm zoals jouw opzet, maar door telkens de waarde te wijzigen in E1 worden de resultaten weergegeven in de kolommen ernaast. Aangezien formules niet echt mijn ding zijn zal je moeten wachten op de formule-wizards hier om je verder te helpen als dit niet werkt voor jou. Marinus rev01.xlsx

Wat jij vraagt is m.i. gewoon onmogelijk in deze layout. Je zal ten eerste al Index-Vergelijken moeten gebruiken want je zoekt van rechts naar links terwijl Vert.Zoeken van links naar rechts zoekt. (kan ook van rechts naar links maar dat leid ons te ver). Dit zal dus al een Array formule moeten worden want je krijgt meerdere resultaten in je eerste opzoeking. Dan moet je elk element van deze Array terug gaan gebruiken om de 2de opzoeking in kolom B te doen om het automerk te krijgen. Wederom een Arrayformule want er zijn terug meerdere resultaten. Maar dan plotseling bij Stuur1 moet je die 2de opzoeking niet meer doen want je krijgt direct het automerk als resultaat. Hoe ga je de formule vertellen dat wanneer de 1ste opzoeking al een automerk als resultaat geeft dat die 2de opzoeking niet meer moet gebeuren ???? Mijn advies is dat je eens even gaat zitten en er eens rustig over nadenkt hoe je een werkende layout kan uitdokteren.

Je vraag is veel te vaag om een volledige oplossing te geven maar dit zal je al op weg helpen. Private Sub CommandButton1_Click() mypath = ThisWorkbook.Path & "\" myfilename = Sheet1.Range("B1").Value Application.CopyObjectsWithCells = False Sheet1.Copy Application.CopyObjectsWithCells = True With ActiveWorkbook Application.DisplayAlerts = False .SaveAs mypath & myfilename, 51 Application.DisplayAlerts = True .Close False End With With CreateObject("outlook.application").createitem(0) .to = "emailadres" .Subject = "onderwerp" .body = "bijgaande tekst" .attachments.Add mypath & myfilename & ".xlsx" .display End With End Sub

Nog makkelijker is in het linkervak het formulier selecteren en op F7 drukken. Nu wordt het code venster rechts geopend op de Userform code.

OK, dan nog maar eentje met Advanced Filter erbovenop. Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("T2:U2")) Is Nothing Then Range("T7").ClearContents Cells(1).CurrentRegion.AdvancedFilter 2, Range("T1:U2"), Range("T6") End If End Sub test dubbele Adv_Filter.xlsm