Data van Dagrapport naar database kopiëren

Status
Niet open voor verdere reacties.
E

edwin13387

Gebruiker
Lid geworden
12 jun 2015
Berichten
46
Hallo,

Zoals de titel al aangeeft wil ik vanuit een dagrapport naar een database copieren.
Nu lijkt mij dit een vrij standaard macro, maar er is 1 probleem:
Ik bak er niets van.

Tot nu toe heb ik via vakundig knip en plakwerk het volgende:(zie einde post)

Dit werkt tot op zekere hoogte:

  • Het bestand OEE wordt geopend, er zijn geen problemen als deze al open is.
  • De ingevulde cellen in het dagrapport worden gecopieerd
  • Deze worden in de database geplakt

Echter als de Macro nog een keer draait pakt hij de zelfde cel als doel, en overschrijft daarmee de oude cellen.

Enkele opmerkingen:
  • Regel 1 is leeg
  • Regel 2 bevat een merged cel met de titel
  • Er staan enkele zaken in die (nog) niets doen, dit om hopelijk de macro beter te maken. Maar ik ben nog aan het kijken hoe dat moet(ik ben halverwege mijn knip/plak werk).

Code: 
Sub data_naar_oee()
'
' data_naar_oee Macro
' data naar oee schrijven
'
Dim i As Long
Dim wb As Workbook
Dim FileToClose As String

Application.ScreenUpdating = False

    On Error Resume Next
    Set wb = Workbooks("OEE.xlsx")
    Set NBOEE = Workbooks("OEE.xlsx").Worksheets("Nieuwe blender")
    Set OBOEE = Workbooks("OEE.xlsx").Worksheets("Oude blender")
    Set GTOEE = Workbooks("OEE.xlsx").Worksheets("Hand blends en G-tanks")
    Set OBLOG = Workbooks("blend log.xlsm").Worksheets("Oude blender")
    Set NBLOG = Workbooks("blend log.xlsm").Worksheets("Nieuwe blender")
    Set GTLOG = Workbooks("blend log.xlsm").Worksheets("Hand blends en G-tanks")
    On Error GoTo 0
    
    If wb Is Nothing Then
        Set wb = Workbooks.Open("I:\OEE\testbestand\OEE.xlsx")
    Else
    End If

    Windows("blend log.xlsm").Activate
    Sheets("Nieuwe blender").Select
    Range("B4:M" & Range("B20000").End(xlUp).Row).Copy
    Windows("OEE.xlsx").Activate
    Sheets("Nieuwe blender").Select
    LastRow = Range("B:B").End(xlUp).Row + 2
    Cells(LastRow, 2).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Windows("blend log.xlsm").Activate
    Sheets("Nieuwe blender").Select
    Range("B4:M" & Range("B20000").End(xlUp).Row).Select
    Selection.ClearContents
'    FileToClose = "I:\OEE\testbestand\OEE.xlsx"
'    Workbooks(Dir(FileToClose)).Save
'    Workbooks(Dir(FileToClose)).Close

End Sub
 
Laatst bewerkt:
Doe ons een lol en maak je code op met de CODE knop; hier is geen beginnen aan :).
 
Kijk eens naar de hoeveelheid meters die we minder hoeven te scrollen, en de leesbaarheid van de code! Overigens is een groot voordeel van code nou juist dat je ook kunt inspringen, zodat je de lussen op de beste manier kan lezen. Dat heb je niet gedaan, wat de leesbaarheid dus alsnog weer verlaagt. Het was eigenlijk de bedoeling dat je de code uit het eerste bericht zou aanpassen, niet zou laten staan en de code in een nieuw bericht zou zetten :).
 
Om de meters wat te verkleinen:d

Code: 
Sub VenA()
Dim wb As Workbook, sh As Worksheet
On Error Resume Next
Set wb = Workbooks("OEE.xlsx")
If wb Is Nothing Then Set wb = Workbooks.Open("C:\Temp\OEE.xlsx") '("I:\OEE\testbestand\OEE.xlsx")
For Each sh In wb.Sheets
    If sh.Name = "Nieuwe blender" Or sh.Name = "Oude blender" Or sh.Name = "Hand blends en G-tanks" Then
        With sh.Range("B4:M" & sh.Cells(Rows.Count, 2).End(xlUp).Row)
            .Copy Workbooks("blend log.xlsm").Sheets(sh.Name).Cells(Rows.Count, 2).End(xlUp).Offset(2)
            .ClearContents
        End With
    End If
Next sh
wb.Close True
End Sub
 
Laatst bewerkt:
bedankt, volgens mij is dit het bijna

Hallo Vena,

Zoals aangegeven ben ik niet bepaald bekend hier in, maar hij werkt nog niet.

Na de verwijzing qua locatie te hebben aangepast(zoals je al had aangegeven met de '), opent het bestand.
Deze sluit ook weer, maar zonder iets te copieren.

Als ik probeer de code te begrijpen staat er het volgende:

  • Open de database
  • kijk naar de sheet naam in de database
  • copieer de data uit de blend log naar deze database (match de sheet namen)
  • sluit de database

mis ik het plak gedeelte?

mvg
Edwin
 
Best wel een goede analyse. Het plak gedeelte mis je niet. Tenzij er formules instaan die je als waarde wilt plakken.

Code: 
sh As Worksheet[COLOR="#FF0000"]s[/COLOR]
is de boosdoener denk ik. De rode s moet weg.

Als code niet werkt dan altijd even de foutonderdrukking uitzetten. Je ziet dan gelijk waar het stuk loopt (een ' zetten voor On Error Resume Next)
 
fouten opgezocht

Hallo,

Helaas is de s weg halen niet de oplossen, hierbij de code's die een fout geven

Code: 
Set wb = Workbooks("OEE.xlsx")
Subscript out of range

Komt normaal niet naar voren, is voor als het bestand al open staat.

Code: 
For Each sh In wb.Sheets
typen komen niet met elkaar overeen (13)
(zonder s: deze eigenschap of methode wordt niet ondersteund door dit object) (438)

Ik ga dus voor met een s, maar wat ik tegenkom op google gaat vooral over text cellen waar als nummer naar verwezen wordt.
Dus gaat over een sheet...

Alvast bedankt,Bekijk bijlage blend log.xlsmBekijk bijlage OEE.xlsx

Voor het gemak de 2 bestanden bijgevoegd, misschien zit het probleem in de extra sheet in blendlog?
(data die er in staat is fictief, is om te testen of alles werkt)
 
Nog meer afstandsreduktie en eerst maar eens kijken of dit werkt.

Code: 
Sub M_snb()
  with getobject("I:\OEE\testbestand\OEE.xlsx")
    For Each sh In .Sheets
      If instr("Nieuwe blenderOude blenderHand blends en G-tanks",sh.name) Then sh.Cells(4,2).resize(sh.cells(Rows.Count, 2).End(xlUp).Row,12).copy Workbooks("blend log.xlsm").Sheets(sh.Name).Cells(Rows.Count, 2).End(xlUp).Offset(2)
    Next
    .Close 0
  end with
End Sub
 
Laatst bewerkt:
helaas

Hallo,

Helaas werkt dit ook niet, wel even een "end with" toegevoegd.
Hij kopieërd 3 regels uit 1 sheet (die niet in de macro vermeld wordt) naar de andere.
(in bijde bestanden zitten sheets die niet mee hoeven te doen in de macro)
 
weer wat gevogeld

Hallo,

Ik zie nu pas dat ik de verkeerde s weg had gehaald...
Nu de goede s weg is, loopt de volledige macro.
Maar hij copieerd van database naar log.
Dus verkeerd om.

mvg
Edwin

Naar het 1 en ander om te hebben gegooit:
Code: 
Sub VenA()
Dim wb As Workbook, sh As Worksheet, wblog As Workbook
On Error Resume Next
Set wb = Workbooks("OEE.xlsx")
Set wblog = Workbooks("blend log.xlsm")
If wb Is Nothing Then Set wb = Workbooks.Open("I:\OEE\testbestand\OEE.xlsx")
For Each sh In wblog.Sheets
    If sh.Name = "Nieuwe blender" Or sh.Name = "Oude blender" Or sh.Name = "Hand blends en G-tanks" Then
        With sh.Range("B4:M" & sh.Cells(Rows.Count, 2).End(xlUp).Row)
            .Copy Workbooks("OEE.xlsx").Sheets(sh.Name).Cells(Rows.Count, 2).End(xlUp).Offset(2)
            .ClearContents
        End With
    End If
Next sh
wb.Close True
End Sub

Bijna bijna bijna!
Hij werkt met 2 problemen:

1: als je verwerkt plakt hij 1 witregel mee, of plakt 1 te laag. Al met al elke dag een witregel.

2: als er geen data in een log staat, op bijv 1 sheet, dan pakt bij de bovenste regels. Daarin staat wat de data inhoud.
 
Laatst bewerkt:
Hij kopieert immer met een t in beide bestanden
 
Ti's wat

Code: 
Sub M_snb()
  with getobject("I:\OEE\testbestand\OEE.xlsx")
    For Each sh In .Sheets
      If instr(" Nieuwe blender Oude blender Hand blends en G-tanks ","" & sh.name & " ") Then sh.Cells(4,2).resize(sh.cells(Rows.Count, 2).End(xlUp).Row,12).copy Workbooks("blend log.xlsm").Sheets(sh.Name).Cells(Rows.Count, 2).End(xlUp).Offset(2)
    Next
    .Close 0
  end with
End Sub
 
Deze macro doet helaas niets, buiten het bestand openen en sluiten.
Ik kan ook niet meer zien of hij iets probeer te kopiëren, het enige wat opvalt is dat in de database de 3 betreffende sheets geselecteerd zijn.
 
Dat openen en sluiten kun jij niet zien.
De macro selecteert niets.
 
hij doet het

Hallo,

Nu doet hij het:
Code: 
Sub VenA()
Dim wb As Workbook, sh As Worksheet, wblog As Workbook
On Error Resume Next
Set wb = Workbooks("OEE.xlsx")
Set wblog = Workbooks("blend log.xlsm")
If wb Is Nothing Then Set wb = Workbooks.Open("I:\OEE\testbestand\OEE.xlsx")
For Each sh In wblog.Sheets
    If sh.Name = "Nieuwe blender" Or sh.Name = "Oude blender" Or sh.Name = "Hand blends en G-tanks" Then
        With sh.Range("B4:M28" & sh.Cells(Rows.Count, 2).End(xlUp).Row)
            .Copy Workbooks("OEE.xlsx").Sheets(sh.Name).Cells(Rows.Count, 2).End(xlUp).Offset(1)
            .ClearContents
        End With
    End If
Next sh
wb.Close True
End Sub
De offset 1 verlaagd en de range strakker gezet. dat 2e is wel jammer, maar kan in princiepe tot 25000 verlengt wordt dus niet zo een probleem.

Bedankt voor de hulp, ik ga nog een beetje bij knippen/plakken.
 
Het 2e kan je bv zo ondervangen

Code: 
lr = sh.Cells(Rows.Count, 2).End(xlUp).Row
If lr > 3 Then
    With sh.Range("B4:M" & lr)
        .Copy Workbooks("OEE.xlsx").Sheets(sh.Name).Cells(Rows.Count, 2).End(xlUp).Offset(1)
        .ClearContents
    End With
End If
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan