Gegevens wegschrijven dmv lijst.

HSV · 26 feb 2012

Dank je Danny,

Ik hoop dat dit hetzelfde resultaat bekomt als 'perfect'.

danny147 · 26 feb 2012

Beste HSV,

Sorteren is perfect :thumb:

Alleen de lege regel met informatie staat er nu onder ipv boven.

Ik denk dat hij die mee sorteert met kolom 9 ?

Als alles afgerond is moeten de tabbladen benoemd worden:

Blad2 --> AA-Kranen
Blad3 --> A-Kranen
Blad4 --> Andere Kranen

Groetjes Danny.

HSV · 26 feb 2012

Danny,

welke (lege) regel met informatie bedoel je (de regel die lichtblauw wordt gemaakt)?

danny147 · 26 feb 2012

Beste HSV,

Had die "lege" uit de regel moeten laten

Ja, de blauwe regel.

Groetjes Danny. :thumb:

HSV · 26 feb 2012

Hallo Danny,

Raar, bij mij staat het gewoon bovenaan.
Ik heb hier en daar nog wat aan de opmaak gedaan, zoals blad 5 is.

Probeer het nog eens.

danny147 · 26 feb 2012

Beste HSV

Ik denk dat ik het weet hoe het komt.

In Post20 heb ik een rar bestandje geplaatst en daar de code ingezet.
Dat bestandje zal de originele versie worden.
Sorry als je het niet gezien had, en ik jou er niet attent op gemaakt heb.

Daar zet hij de blauwe regel er wel onder en bij jou niet.

Groetjes Danny. :thumb:

HSV · 26 feb 2012

Dat was me dus ontgaan.

Verander deze regel even: staat er drie keer in.

Code:

  .Range(.Cells(Rij, 1), .Cells(.Cells(Rows.Count, 3).End(xlUp).Row, 10)).Sort .Cells(Rij - 1, 9)[COLOR="#FF0000"], , , , , , , xlYes[/COLOR]

danny147 · 26 feb 2012

Beste HSV

Dat is het hé :thumb:

Dit heb ik onderaan als bijvulling geplaatst:

Code:

 Sheets("Blad2").Name = "AA-Kranen"
 Sheets("Blad3").Name = "A-Kranen"
 Sheets("Blad4").Name = "Andere Kranen"

Nu nog de laatste vraag tot de perfectie denk ik toch :d

Via intranet op ons werk haal ik 4 xls bestandjes en plaats deze in mijn documenten op de H-schijf
In elk bestandje op Blad1 staan de gegevens, deze plaats ik alle 4 onder elkaar in een nieuw bestand.

Bestandjes zijn:
718.EL.xls
718.ME.xls
718.EXT.xls
726.KO.xls

Is er een mogelijkheid dat ik een nieuw werkmap opent met als naam LK-Kranen de gegevens van alle Bladen1 onder elkaar plaats, gevolgd door de code in Bald1 ( het verwijderen van lege rijen) en dit voor de bestaande code kan plaatsen ?
En deze daarna opslaan in mijn documenten op de H-schijf.

Dit zou voor mij de Max zijn :d

Groetjes Danny. :thumb:

HSV · 27 feb 2012

Zet eens 4 bestandjes met wat info in een mapje, genaamd "Danny", op de D schijf (in dit geval).
Zet deze code ergens in een bestandje.
Laat de code lopen.
De code maakt een bestandje aan met de naam 'LK-Kranen.xls' op de 'H' schijf.
In bestand 'LK-Kranen.xls' blad1 worden nu alle gegevens onder elkaar gezet van alle 4 bestandjes (gebaseerd op kolom A)
van de 'D' schijf .

Code:

Sub hsv()
Workbooks.Add
ActiveWorkbook.SaveAs "H:\LK-Kranen.xls"

Dim bestandopen
 bestandopen = Dir("D:\Danny\*")
    Do Until bestandopen = ""
      If bestandopen = "" Then Exit Do
        Workbooks.Open "D:\Danny\" & bestandopen
          With Workbooks("LK-Kranen.xls")
       ActiveWorkbook.Sheets(1).UsedRange.Copy .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
         End With
        Application.DisplayAlerts = False
        Workbooks(bestandopen).Close True
      bestandopen = Dir
    Loop
    Workbooks("LK-Kranen.xls").Close True
   Application.DisplayAlerts = True
End Sub

danny147 · 27 feb 2012

Beste HSV,

In kolom A staan geen gegevens, daarom plaatst hij ook enkel de gegevens van het laatste bestandje.

Groetjes Danny. :thumb:

HSV · 27 feb 2012

Maak van de één even een twee.
Nu zou het goed moeten gaan.

Code:

.Sheets(1).Cells(Rows.Count,[COLOR="#FF0000"] 1[/COLOR]).End(xlUp).Offset(1)

danny147 · 27 feb 2012

Beste HSV,

Dit lukt ook niet, hij schrijft enkel de gegevens een kolom verder.

In bijlage de bestandjes.

De code die ik thuis gebruik is deze:

Code:

Sub hsv()
Workbooks.Add
ActiveWorkbook.SaveAs "G:\LK-Kranen.xls"

Dim bestandopen
 bestandopen = Dir("D:\Danny\*")
    Do Until bestandopen = ""
      If bestandopen = "" Then Exit Do
        Workbooks.Open "D:\Danny\" & bestandopen
          With Workbooks("LK-Kranen.xls")
       ActiveWorkbook.Sheets(1).UsedRange.Copy .Sheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(2)
         End With
        Application.DisplayAlerts = False
        Workbooks(bestandopen).Close True
      bestandopen = Dir
    Loop
    Workbooks("LK-Kranen.xls").Close True
   Application.DisplayAlerts = True
End Sub

Groetjes Danny. :thumb:

HSV · 27 feb 2012

Nieuwe poging Danny.

Code:

Sub hsv()
Application.ScreenUpdating = False
Workbooks.Add
ActiveWorkbook.SaveAs "D:\LK-Kranen.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.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.xls")
        .Sheets(1).Columns.AutoFit
        .Close True
      End With
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

danny147 · 27 feb 2012

Beste HSV,

Nu lukt het :thumb:

Kan je dit er nog tussen plaatsen ?

Code:

      With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
      End With

Zodat er geen randen zijn rond de cellen geen opvulkleur en geen tekstkleur.

Groetjes Danny. :thumb:

HSV · 27 feb 2012

Zo beter?

Code:

Sub hsv()
Application.ScreenUpdating = False
Workbooks.Add
ActiveWorkbook.SaveAs "G:\LK-Kranen.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.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.xls")
            With .Sheets(1)
               .Cells(1).CurrentRegion.AutoFormat Format:=xlRangeAutoFormatClassic1
               .Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
               .Columns.AutoFit
            End With
        .Close True
      End With
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

danny147 · 1 mrt 2012

Beste HSV,

Kon niet vroeger reageren

Heb hier en daar wat aangepast en hij doet het nog steeds, zoals het moet.

Bij het wegschrijven naar de verschillende tabbladen, ontbreekt er de lijst in het bestandje
LK-Kranen.xls.
Nu had ik gedacht, deze in een bestandje te plaatsen (Lijst_LK's.xls) en deze ook onder de map Danny te plaatsen.
Dit blijkt niet de goede keuze te zijn, aangezien bereik "B1:J" wordt weggeschreven.
In bestand Lijst_LK's zouden kolommen A:C op plaats AA:AC moeten staan.

Jij soms een idee dit op te lossen ??

Ook zou bij het weschrijven de rijen moeten verwijderd worden in Blad1.

Zie in bijlage de aangepaste codes en de lijst.

Groetjes Danny. :thumb:

HSV · 1 mrt 2012

Bedoel je het zo Danny?

Het laatst stukje van de code.
Als bestand 'Loopkranen 2012.xls' nog open staat.

Code:

Loop
      With Workbooks("LK-Kranen.xls")
            With .Sheets(1)
       [COLOR="#FF0000"] Workbooks("loopkranen 2012.xls").Sheets("Sheet1").Range("AA1").CurrentRegion.Copy .Range("AA1")[/COLOR]               .Cells(1).CurrentRegion.AutoFormat Format:=xlRangeAutoFormatClassic1
               .Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
               .Columns.AutoFit
            End With
        .Close True
      End With
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

danny147 · 2 mrt 2012

Beste HSV,

Hij doet het goed als het bestandje open staat.

Nu probeer ik het bestandje automatisch te open, wat hij ook doet.
Maar hij schrijft de gegevens niet weg op plaats AA:AC
Daarna probeer ik het te sluiten.

Zie de rode tekst in de code.

Code:

Sub hsv()
Application.ScreenUpdating = False
Workbooks.Add
ActiveWorkbook.SaveAs "G:\LK-Kranen.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.xls").Sheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1)
      End With
        Application.DisplayAlerts = False
        Workbooks(bestandopen).Close True
      bestandopen = Dir
 Loop
        [B][/B][COLOR="#FF0000"]Workbooks.Open "D:\Lijst_LK's.xls"[/COLOR]  
    With Workbooks("LK-Kranen.xls")
        On Error Resume Next
            Range("J2:J13000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        On Error GoTo 0
            Range("B3:J13000").Sort Key1:=Range("C3"), Order1:=xlAscending
            With .Sheets(1)
                Workbooks("Lijst_LK's.xls").Sheets("Blad1").Range("AA1").CurrentRegion.Copy .Range("AA1")
               .Cells(1).CurrentRegion.AutoFormat Format:=xlRangeAutoFormatClassic1
               .Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
               .Columns.AutoFit
            End With
        .Close True
      End With
      [B][/B][COLOR="#FF0000"]Workbooks("Lijst_LK's.xls").Close True[/COLOR]   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

Groetjes Danny. :thumb:

HSV · 2 mrt 2012

Zo moet het beter gaan..

Code:

Loop
           
    With Workbooks("LK-Kranen.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")
               .Cells(1).CurrentRegion.AutoFormat Format:=xlRangeAutoFormatClassic1
               .Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
               .Columns.AutoFit
            End With
        .Close True
      End With
      Workbooks("Lijst_LK's.xls").Close True
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

danny147 · 2 mrt 2012

Beste HSV,

Deze doet het weer perfect

Nog 2 probleempjes die we moeten oplossen en dan is de kous af

1. In kolom C staan er overal spaties achter de namen en getallen.
Hoe krijg ik deze weg ?
Heb geprobeerd deze te selecteren dan vervangen spaties naar "" en dat lukt.
Kan dit met een code ?

2. Bij het wegschrijven naar Blad 2, 3 en 4 moeten de regels verwijderd worden in Blad1.

Groetjes Danny, :thumb:

Gegevens wegschrijven dmv lijst.

Inventaris

Bijlagen

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Inventaris

Bijlagen

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Bijlagen

Inventaris

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Bijlagen

Inventaris

Terugkerende gebruiker

Inventaris

Terugkerende gebruiker

Wij waarderen jouw privacy