Gegevens wegschrijven dmv lijst.

HSV · 2 mrt 2012

Vraag 1 = LK-Kranen.xls ?
vraag 2 = Loopkranen 2012.xls ?

danny147 · 2 mrt 2012

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:

HSV · 2 mrt 2012

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 ?

danny147 · 2 mrt 2012

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

Groetjes Danny. :thumb:

HSV · 3 mrt 2012

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.

danny147 · 3 mrt 2012

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:

HSV · 3 mrt 2012

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.

Code:

Dim wrksht As Worksheet
    For Each wrksht In Worksheets
        wrksht.Columns.AutoFit
    Next wrksht

danny147 · 3 mrt 2012

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

Groetjes Danny. :thumb:

danny147 · 4 mrt 2012

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:

HSV · 4 mrt 2012

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.

danny147 · 4 mrt 2012

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

Groetjes Danny. :thumb:

HSV · 4 mrt 2012

Zet even een punt voor "cells".

Code:

.Cells(i, j) = RTrim(.Cells(i, j))

danny147 · 4 mrt 2012

Beste HSV,

Loopt steeds verder op volgende regel:

Code:

Next j

Groetjes Danny. :thumb:

HSV · 4 mrt 2012

Zet j eens op 10

Code:

For J = 1 to 10

danny147 · 4 mrt 2012

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

Groetjes Danny :thumb:

HSV · 4 mrt 2012

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

danny147 · 4 mrt 2012

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:

HSV · 4 mrt 2012

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

danny147 · 5 mrt 2012

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:

HSV · 5 mrt 2012

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.

Gegevens wegschrijven dmv lijst.

Inventaris

Terugkerende gebruiker

Bijlagen

Inventaris

Terugkerende gebruiker

Inventaris

Bijlagen

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Inventaris

Bijlagen

Terugkerende gebruiker

Inventaris

Wij waarderen jouw privacy