Ga naar inhoud

Welkom op PC Helpforum!
PC Helpforum helpt GRATIS computergebruikers sinds 2006. Ons team geeft via het forum professioneel antwoord op uw vragen en probeert uw pc problemen zo snel mogelijk op te lossen. Word lid vandaag, plaats je vraag online en het PC Helpforum-team helpt u graag verder!

bakerman

Lid
  • Aantal items

    82
  • Registratiedatum

  • Laatst bezocht

Over bakerman

  • Titel
    Nieuweling

Profiel Informatie

  • Geslacht
    Man
  • Land
    België

Recente bezoekers van dit profiel

De recente bezoekers block is uitgeschakeld en zal niet meer getoond worden aan gebruikers.

  1. Wil je toch een formule. In D2 en doortrekken naar beneden. =LINKS($C2;VIND.ALLES(" ";$C2;1)-1)
  2. Nog een bemerking. Hoeveel plaatsnamen zijn er met kengetal 015 ? (afgaande op je voorbeeldbestand) Hoe ga je dan bepalen om welke plaats het gaat ?
  3. bakerman

    Geavanceerd filteren

    Een andere mogelijkheid. Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$E$2" Then Cells(1, 10).CurrentRegion.Clear Cells(1).CurrentRegion.AdvancedFilter 2, [E1:E2], Cells(1, 10) End If End Sub
  4. Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("b2")) Is Nothing Then With Sheets("blad2") .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Range("a2").Resize(, 2).Value End With End If End Sub
  5. =SUBSTITUEREN(RK[-2];".";"")-RK[-1] @ emiel Rechter Test.xlsm klikken.
  6. Staan je weken horizontaal. Formule in A2 en naar rechts doortrekken. =VERSCHUIVING([Map2]Blad1!$B$42;0;(KOLOM()-1)*3) Staan je weken vertikaal. Formule in B1 en naar beneden dooretrekken. =VERSCHUIVING([Map2]Blad1!$B$42;0;(RIJ()-1)*3)
  7. Een ideetje om makkelijk alle bladnamen in een kolom te krijgen. BladNamen_Formula.xlsm
  8. Kleine aanpassing. Sub SortBirthdays() Application.ScreenUpdating = False Dim lRow As Long With Blad1 lRow = .Cells(.Rows.Count, 1).End(xlUp).Row .Range("Z2:Z" & lRow).FormulaR1C1 = "=TEXT(RC3,""MMDD"")" .Range("A2:Z" & lRow).Sort .Range("Z2"), xlAscending, , , , , , xlNo .Range("Z2:Z" & lRow).Clear End With Application.ScreenUpdating = True End Sub en dan is dit het resultaat.
  9. Deze sorteert op maand en dag. Je kan de dag en maandkolom zonder probleem verwijderen. Sub SortBirthdays() Application.ScreenUpdating = False Dim lRow As Long With Blad1 lRow = .Cells(.Rows.Count, 1).End(xlUp).Row .Range("Z2:Z" & lRow).FormulaR1C1 = "=TEXT(RC3,""MMDD"")" .Range("A2:Z" & lRow).Sort .Range("Z2"), xlAscending, , , , , , xlYes .Range("Z2:Z" & lRow).Clear End With Application.ScreenUpdating = True End Sub
  10. Had 'm om te testen op vandaag gezet en vergeten terug te zetten. Private Sub Workbook_Open() With Sheets(1) For i = 2 To .Range("a1").End(xlDown).Row If (Day(CDate(.Range("c" & i).Value)) - Day(Date) = 1) * (Month(CDate(.Range("c" & i).Value)) - Month(Date) = 0) Then msg = msg & .Range("b" & i).Value & vbLf & vbLf End If Next i End With If msg <> vbNullString Then MsgBox msg & vbLf & "is (zijn) morgen jarig.", vbInformation, "Verjaardagen." End Sub
  11. I.p.v. 3X op OK te moeten drukken. Private Sub Workbook_Open() With Sheets(1) For i = 2 To .Range("a1").End(xlDown).Row If (Day(CDate(.Range("c" & i).Value)) - Day(Date) = 0) * (Month(CDate(.Range("c" & i).Value)) - Month(Date) = 0) Then msg = msg & .Range("b" & i).Value & vbLf & vbLf End If Next i End With If msg <> vbNullString Then MsgBox msg & vbLf & "is (zijn) morgen jarig.", vbInformation, "Verjaardagen." End Sub
  12. Deze heb ik je ook al eens eerder gegeven. Sub UpdateBestanden() Dim FilePath$, Row&, Column&, Address$ 'change constants & FilePath below to suit '*************************************** Const SheetName$ = "Personalia" Address = Cells(11, 2).Address FilePath = "D:\Test2\" '*************************************** With CreateObject("scripting.filesystemobject").getfolder(FilePath) For Each fl In .Files If Right(fl.Name, 5) = ".xlsx" Then Cells(Rows.Count, 1).End(xlUp).Offset(1) = fl.Name Filename = fl.Name Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = GetData(FilePath, Filename, SheetName, Address) Columns.AutoFit End If Next End With End Sub Private Function GetData(path, file, sheet, Address) Dim Data$ Data = "'" & path & "[" & file & "]" & sheet & "'!" & _ Range(Address).Range("A1").Address(, , xlR1C1) GetData = ExecuteExcel4Macro(Data) End Function
  13. Een andere oplossing. Sub tst() Dim dic As Object, sn, i As Long sn = Blad2.Cells(1).CurrentRegion.Value Set dic = CreateObject("scripting.dictionary") For i = 2 To UBound(sn) If Not dic.exists(sn(i, 1)) Then dic.Add sn(i, 1), sn(i, 2) Else: dic.Item(sn(i, 1)) = dic.Item(sn(i, 1)) + sn(i, 2) End If Next sn = Blad1.Cells(1).CurrentRegion.Resize(, 3).Value For i = 2 To UBound(sn) If dic.exists(sn(i, 2)) Then sn(i, 3) = dic.Item(sn(i, 2)) Else: sn(i, 3) = 0 End If Next Blad1.Cells(1).Resize(UBound(sn), 3) = sn End Sub
  14. Selecteer C2 en kies dan voor Voorwaardelijke Opmaak in het Lint. Kies Formule gebruiken om te kiezen welke cellen worden opgemaakt. Zet volgende formule in de witte balk. =$C$2 < $B$2 + 15 Kies dan je Opmaak en klik OK.
  15. Wijzig de Const wDir in de correcte map waar alle bestanden staan. Sub ConsolidateAll() Dim rsCon As Object, rsData As Object, sFileName As String Dim Prov As String, ExProp As String, resarr ', wDir As String Const wDir = "D:\Test2\" Prov = IIf(Val(Application.Version) < 12, "Microsoft.Jet.OLEDB.4.0", "Microsoft.ACE.OLEDB.12.0") ExProp = IIf(Val(Application.Version) < 12, "8.0", "12.0") Sheets(1).Cells(1).CurrentRegion.Offset(1).ClearContents sFileName = Dir(wDir & "*.xlsx") Do While sFileName <> "" If sFileName <> ThisWorkbook.Name Then Set rsCon = CreateObject("ADODB.Connection"): Set rsData = CreateObject("ADODB.Recordset") rsCon.Open "Provider=" & Prov & ";Data Source=" & wDir & sFileName & _ ";Extended Properties=""Excel " & ExProp & ";HDR=No"";" rsData.Open "SELECT * FROM [Personalia$B2:B14];", rsCon, 0, 1, 1 If Not rsData.EOF Then resarr = rsData.GetRows End If Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(resarr, 1) + 1, UBound(resarr, 2) + 1) = resarr sFileName = Dir: rsData.Close: Set rsData = Nothing: rsCon.Close: Set rsCon = Nothing End If Loop End Sub janlazeure.xlsm
Logo

OVER ONS

PC Helpforum helpt GRATIS computergebruikers sinds juli 2006. Ons team geeft via het forum professioneel antwoord op uw vragen en probeert uw pc problemen zo snel mogelijk op te lossen. Word lid vandaag, plaats je vraag online en het PC Helpforum-team helpt u graag verder!

×
×
  • Nieuwe aanmaken...

Belangrijke informatie

We hebben cookies geplaatst op je toestel om deze website voor jou beter te kunnen maken. Je kunt de cookie instellingen aanpassen, anders gaan we er van uit dat het goed is om verder te gaan.