• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Gegevens wegschrijven dmv lijst.

Status
Niet open voor verdere reacties.
Vraag 1 = LK-Kranen.xls ?
vraag 2 = Loopkranen 2012.xls ?
 
Beste HSV, ;)

1. LK-Kranen.xls --> in code hsv
2. LK-Kranen.xls --> in code AA_Kranen__naar_blad2

Zie bijlage voor de laaste update van de code.

Mijn codes staan in mijn persoonlijke macrowerkmap.

Groetjes Danny. :thumb:
 

Bijlagen

Helaas ben ik de draad ergens kwijt geraakt.
Je zet er een leeg bestandje neer.
Is dit enkel voor de code die eigenlijk in het bestand 'Loopkranen 2012' hoort ?
 
Beste HSV, ;)

Vanaf post#28 is de naam veranderd van zodra er automatisch een bestandje wordt aangemaakt.
Het bestandje noemt nu LK-Kranen.xls

De code staat nergens meer in een bestandje, enkel nog in mijn persoonlijke macrowerkmap.

Ziehier het bestandje na het uitvoeren van de code hsv.

Zoals je kan zien in kolom C op tabblad1 staan er allemaal spaties achter de tekst en cijfers.
Deze zou ik graag wegwillen in de code hsv.

Bij het uit voeren van de code in code AA_Kranen__naar_blad2 moeten ook de rijen verwijderd worden in Blad1, die zijn weggeschreven naar Blad2 , 3 en 4.

Hopelijk kan je nu de draad terug opnemen :D

Groetjes Danny. :thumb:
 
Code hsv bijgewerkt.
Code AA_Kranen__naar_blad2 heb ik twee versies (blad2 en blad_test2).
De blad2 zou langzamer zijn dan blad_test2 door meerdere schrijfbewerkingen.
Het komt doordat je vanaf onderen rijen moet verwijderen.
De eerste loopt twee keer hetzelfde rondje, maar alles staat in volgorde.
De tweede doet alles in één loop, maar zet alles in omgekeerde volgorde.
 

Bijlagen

Beste HSV, ;)

Dat ziet er perfect uit.

Heb de eerste code gebruikt (AA_Kranen__naar_blad2), het duurt wat langer maar alles staat netjes gerangschikt.

Heb van de 2 codes 1 gemaakt en van onder nog wat bijgezet om de kolommen autofit te maken.

Kan je hier nog eens naar kijken of dit wel klopt, hetgeen ik er bij geplaatst heb.
De code op zich werkt perfect in 1 keer.

Na controle van jou zal ik de topic op opgelost plaatsen.

Code:
Sub Uitvoeren_naar_AA_Kranen()
Application.ScreenUpdating = False
Workbooks.Add
ActiveWorkbook.SaveAs "G:\LK-Kranen " & Format(Date, "d-mm-yyyy") & ".xls"

Dim bestandopen
 bestandopen = Dir("D:\Danny\*")
    Do Until bestandopen = ""
      If bestandopen = "" Then Exit Do
        Workbooks.Open "D:\Danny\" & bestandopen
      With ActiveWorkbook.Sheets(1)
       .Range("B1:J" & .Cells.SpecialCells(xlLastCell).Row).Copy _
       Workbooks("LK-Kranen " & Format(Date, "d-mm-yyyy") & ".xls").Sheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1)
      End With
        Application.DisplayAlerts = False
        Workbooks(bestandopen).Close True
      bestandopen = Dir
Loop
           
    With Workbooks("LK-Kranen " & Format(Date, "d-mm-yyyy") & ".xls")
     With .Sheets(1)
        On Error Resume Next
            .Range("J2:J13000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        On Error GoTo 0
            .Range("B3:J13000").Sort Key1:=Range("C2"), Order1:=xlAscending
              Workbooks.Open "D:\Lijst_LK's.xls"
                Workbooks("Lijst_LK's.xls").Sheets("Blad1").Range("AA1").CurrentRegion.Copy .Range("AA1")
            For I = 1 To .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row).Rows.Count
               .Cells(I, 3) = RTrim(.Cells(I, 3))
                  Next I
               .Cells(1).CurrentRegion.AutoFormat Format:=xlRangeAutoFormatClassic1
               .Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
               .Columns.AutoFit
            End With
       End With
      Workbooks("Lijst_LK's.xls").Close True
   Application.DisplayAlerts = True
       Dim cl      As Range
    Dim C       As Variant
    Dim Rij     As Long
    
 sq = "Roepnaam" & "|" & "Machine" & "|" & "Omschrijving" & "|" & "Werkorder" & "|" & "Status" & "|" & "BeginTijdstipGepland" _
& "|" & "EindTijdstipGepland" & "|" & "CapacitaitsgroepID" & "|" & "Werkvoorbereider" & "|"
    
With Sheets("Blad1")
For Each cl In .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row)

  If cl > 0 Then
       Set C = .Range("AA2:AC254").Find(cl, , xlValues, xlWhole)
       If Not C Is Nothing Then
 kolom = Mid(C.Address, 3, 1)
    Select Case kolom
    
 Case "A"
    With Sheets("Blad2").Cells(Rows.Count, 3).End(xlUp)
        If cl <> naam Then
          Rij = .Offset(1).Row
         .Offset(1, -2).Resize(, 10).Interior.ColorIndex = 37
         .Offset(1, -2) = cl
         .Offset(1, -1).Resize(, 9) = Split(sq, "|")
        End If
       End With
    With Sheets("Blad2")
     .Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
     .Range(.Cells(Rij, 1), .Cells(.Cells(Rows.Count, 3).End(xlUp).Row, 10)).Sort .Cells(Rij - 1, 9), , , , , , , xlYes
    End With
 Case "B"
    With Sheets("Blad3").Cells(Rows.Count, 3).End(xlUp)
        If cl <> naam Then
          Rij = .Offset(1).Row
         .Offset(1, -2).Resize(, 10).Interior.ColorIndex = 37
         .Offset(1, -2) = cl
         .Offset(1, -1).Resize(, 9) = Split(sq, "|")
        End If
      End With
    With Sheets("Blad3")
     .Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
     .Range(.Cells(Rij, 1), .Cells(.Cells(Rows.Count, 3).End(xlUp).Row, 10)).Sort .Cells(Rij - 1, 9), , , , , , , xlYes
    End With
      
 Case "C"
    With Sheets("Blad4").Cells(Rows.Count, 3).End(xlUp)
        If cl <> naam Then
          Rij = .Offset(1).Row
         .Offset(1, -2).Resize(, 10).Interior.ColorIndex = 37
         .Offset(1, -2) = cl
         .Offset(1, -1).Resize(, 9) = Split(sq, "|")
        End If
      End With
    With Sheets("Blad4")
     .Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
     .Range(.Cells(Rij, 1), .Cells(.Cells(Rows.Count, 3).End(xlUp).Row, 10)).Sort .Cells(Rij - 1, 9), , , , , , , xlYes
    End With
       End Select
     End If
   End If
   If Not cl Is Nothing Then
naam = cl
   End If
  Next cl
 
For I = .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row).Rows.Count To 2 Step -1
If .Cells(I, 3) > 0 Then
       Set C = .Range("AA2:AC254").Find(.Cells(I, 3), , xlValues, xlWhole)
       If Not C Is Nothing Then
     .Cells(I, 3).Offset(, -2).Resize(, 10).Delete shift:=xlUp
   End If
  End If
 Next I
End With

    Dim wrksht As Worksheet
    For Each wrksht In Worksheets
        wrksht.Select
        Cells.EntireColumn.AutoFit
    Next wrksht
 
 Sheets("Blad2").Name = "AA-Kranen"
 Sheets("Blad3").Name = "A-Kranen"
 Sheets("Blad4").Name = "Andere Kranen"
 
Application.ScreenUpdating = True
End Sub

Groetjes Danny. :thumb:
 
Iets korter Danny.

Er gebeurt ook heel wat in je bestand, dus een paar seconden meer of minder.
Of z’n snelle Pc kopen als @Warme bakkertje. :p

Code:
Dim wrksht As Worksheet
    For Each wrksht In Worksheets
        wrksht.Columns.AutoFit
    Next wrksht
 
Beste HSV, ;)

Bedankt voor alles :thumb:

Dit bespaart mij een paar uurtjes van kop tot teen om dit handmatig af te werken.

Mijn PC deed er maar een halve sec langer op dan die van Warme bakkertje :D

Groetjes Danny. :thumb:
 
Beste HSV, ;)

Een bijkomend vraagje:

Om alle spaties te verwijderen na tekst en waarden voor ALLE kolommen wat moet er dan aan de volgende regel aangepast worden ??

Code:
For I = 1 To .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row).Rows.Count
.Cells(I, 3) = RTrim(.Cells(I, 3))
Next I

Had geprobeerd met: .Range("B2:J4000" &.... maar dat lukt niet.

Groetjes Danny. :thumb:
 
Laatst bewerkt:
Code:
Sub tst()
Dim i As Long, j As Long
With Sheets("Blad1")
 For i = 1 To .UsedRange.Rows.Count 'rijen 
 For j = 1 To .UsedRange.Columns.Count 'kolommen
   Cells(i, j) = RTrim(Cells(i, j))
  Next j
 Next i
End With
End Sub
Je kan natuurlijk ook het aantal kolommen opgeven.
 
Beste HSV, ;)

In bestaande code doet hij het niet, de code blijft lopen.
De code moet wel in Workbooks("LK-Kranen " & Format(Date, "d-mm-yyyy") & ".xls") lopen.

Rood jouw stukje nieuwe code.
Groen bestaande code --> doet het perfect.

Zie stukje code:

Code:
    With Workbooks("LK-Kranen " & Format(Date, "d-mm-yyyy") & ".xls")
     With .Sheets(1)
        On Error Resume Next
            .Range("J2:J13000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        On Error GoTo 0
            .Range("B3:J13000").Sort Key1:=Range("C2"), Order1:=xlAscending
              Workbooks.Open "D:\Lijst_LK's.xls"
                Workbooks("Lijst_LK's.xls").Sheets("Blad1").Range("AA1").CurrentRegion.Copy .Range("AA1")
               For i = 1 To .UsedRange.Rows.Count 'rijen
                    For j = 1 To .UsedRange.Columns.Count 'kolommen
                    Cells(i, j) = RTrim(Cells(i, j))
                Next j
                Next i
            'For I = 1 To .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row).Rows.Count
               '.Cells(I, 3) = RTrim(.Cells(I, 3))
                '  Next I
               .Cells(1).CurrentRegion.AutoFormat Format:=xlRangeAutoFormatClassic1
               .Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
               .Columns.AutoFit
            End With
        '.Close True
      End With

Heb nog iets ontdekt, maar dat is voor straks :D

Groetjes Danny. :thumb:
 
Laatst bewerkt door een moderator:
Zet even een punt voor "cells".
Code:
.Cells(i, j) = RTrim(.Cells(i, j))
 
Beste HSV, ;)

Loopt steeds verder op volgende regel:

Code:
Next j

Groetjes Danny. :thumb:
 
Zet j eens op 10
Code:
For J = 1 to 10
 
Beste HSV, ;)

Nu fout op de volgende regel:

Code:
.Cells(1).CurrentRegion.AutoFormat Format:=xlRangeAutoFormatClassic1

Wat ik ook zie is, dat alle cellen nu leeg zijn :confused:

Groetjes Danny :thumb:
 
Phoe, moet er wel steeds weer opnieuw inkomen.
Ik heb voor mezelf de bestanden ergens anders staan.
Code:
On Error GoTo 0
            .Range("B3:J13000").Sort Key1:=Range("C2"), Order1:=xlAscending
              Workbooks.Open "D:\Lijst_LK's.xls"
                Workbooks("Lijst_LK's.xls").Sheets("Blad1").Range("AA1").CurrentRegion.Copy .Range("AA1")
           For i = 1 To .UsedRange.Rows.Count 'rijen
                    For j = 1 To 10 'kolommen
                    .Cells(i, j) = RTrim(.Cells(i, j))
                Next j
                Next i

               .Range("B2:J" & .Cells.SpecialCells(11).Row).AutoFormat Format:=xlRangeAutoFormatClassic1
               .Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
               .Columns.AutoFit
            End With
        .Close True
 
Beste HSV, ;)

Dat werkt weer goed.

Wat ik ook gezien hebt, dat is bij het uitvoeren van het 2de gedeelte van de code dat er geen gegevens geplaatst worden in kolom B en J

Groetjes Danny. :thumb:
 
Ik heb de vernieuwde code in het bestandje gezet.
Het is niet gemakkelijk om je bij te benen. :d
 

Bijlagen

Beste HSV, ;)

Heb code van jou met deze van mij vergeleken en ziet er hetzelfde uit op volgende regel na:

Application.SheetInNewWorkbook = 3 --> ???

Ziehier bestandje na het uitvoeren van de code.

Je merkt op dat er geen gegevens staan in kolom B en J

Kan je hier nog eens naar kijken ?

Groetjes Danny, :thumb:
 
verander:
Code:
.Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(, 7) = cl.Resize(, 7).Value
in.
Code:
.Cells(Rows.Count, 3).End(xlUp).Offset(1, -1).Resize(, 10) = cl.Offset(, -1).Resize(, 10).Value
Staat er drie keer in.
Er is iets meer veranderd dan alleen deze regel.

Code:
Application.SheetInNewWorkbook = 3
Je hebt vier bladen nodig, dus wordt er een nieuw werkbook aangemaakt met vier werkbladen.
Code:
Application.SheetInNewWorkbook = 4
Onderaan heb ik het weer op drie gezet, anders krijg je altijd vier bladen bij elke nieuwe document die je aanmaakt.
De regels ".Close True", en "End With" zijn ook verhuist naar onderen, opdat je de codes aan elkaar hebt gekoppeld.
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan