Typen komen niet overeen; wat doe ik fout?

[MeltedForest]

Ik heb de volgende code en bij de vetgedrukte regel krijg ik de melding: typen komen niet overeen. Weet iemand wat ik fout doe?

Sub Knop11_BijKlikken()
  Dim CurCell As Range
  Dim AppXls As Excel.Application
  Dim ObjWb As Excel.Workbook
  Dim ObjWs As Excel.Worksheet
  Dim strFilename As String
  Set AppXls = CreateObject("Excel.Application")
  
  For Each CurCell In Selection.Rows
    strFilename = ThisWorkbook.Path & "\Archief " & _
    Format(Range("E" & CurCell.Rows.Row).Value, "yyyy") & ".xls"
    
    If Dir(strFilename) <> "" Then
      Set ObjWb = AppXls.Workbooks.Open(strFilename)
      Set ObjWs = ObjWb.Worksheets(1)
    Else
      Set ObjWb = AppXls.Workbooks.Add
      Set ObjWs = ObjWb.Worksheets(1)
      ObjWb.SaveAs (strFilename)
    End If
    
[B]    CurCell.Rows.EntireRow.Copy Sheets(ObjWs).Cells(Rows.Count, 2).End(xlUp).Offset(, -1)[/B]
    'CurCell.Rows.EntireRow.ClearContents
    
    ObjWb.Close (SaveChanges = True)
      
  Next CurCell
End Sub

 

[Wigi]

En wat zou een constructie als

Range("E" & CurCell.Rows.Row

moeten doen? Daar begrijp ik het doel niet van.

 

[MeltedForest]

Beste Wigi,

    strFilename = ThisWorkbook.Path & "\Archief " & _
    Format(Range("E" & CurCell.Rows.Row).Value, "yyyy") & ".xls"

zorgt ervoor dat de bestandsnaam het archief van het goede jaartal krijgt.
Bijv. in E11 staat 16-12-2008 en het huidige bestand staat in F:\Mijn Documenten dan wordt strFilename: "F:\Mijn Documenten\Archief 2008.xls". Staat in E10 16-11-2007 dan wordt het Archief 2007.xls, snap je?

Daarna checkt de code of het bestand al bestaat, bestaat het dan opent de code het bestand, bestaat het niet dan maakt de code het bestand aan. :thumb:

Het probleem ligt nu eigenlijk bij de vetgedrukte regel, de rest werkt zoals beoogd

 

[Roncancio]

Als je de vetgedrukte regel verandert in onderstaande, dan werkt het wel.
CurCell.Rows.EntireRow.Copy Sheets(ObjWs.Name).Cells(Rows.Count, 2).End(xlUp).Offset(, -1)
Alleen het rode vetgedrukte gedeelte is aangepast.

Met vriendelijke groet,


Roncancio

 

[MeltedForest]

Roncancio,
Allereerst bedankt voor je bijdrage; ik ben weer een error verder gekomen.
Nu geeft hij de melding "fout 9: het subscript valt buiten bereik". :shocked:
Weet je hoe ik dat kan oplossen?

 

[Roncancio]

Roncancio,
Allereerst bedankt voor je bijdrage; ik ben weer een error verder gekomen.
Nu geeft hij de melding "fout 9: het subscript valt buiten bereik". :shocked:
Weet je hoe ik dat kan oplossen?

Waar krijg je de error want bij mij werkt het prima?

Met vriendelijke groet,


Roncancio

 

[MeltedForest]

Bij dezelfde regel.
Ik zal wel even een voorbeeldbestandje in elkaar zetten. :thumb:

Edit//
Voorbeeldbestand :
In Tab "Totaaloverzicht" staat de knop die de code aanroept.
De code staat in de module "Archiveren".
De gebruiker selecteert een bereik gegevens in de tab totaaloverzicht en drukt op de knop om het naar een ander bestand over te zetten.
//Edit

 

[MeltedForest]

Kan iemand me hiermee helpen?

 

[snb]

Verdiep je eerst eens in de basisregels van VBA (gebruik van haakjes bijvoorbeeld).
Gebruik de hulpfunktie van VBA eens vaker. Voorbeeld: entirerow.copy in combinatie met .offset(,-1) (=1 kolom naar links) is 'vreemd'.
Het overnemen van code van anderen is geen bezwaar zolang je de kwaliteit van die code kunt beoordelen en begrijpt wat die doet (en niet alleen beoordelen op resultaat).

Sub Knop11_BijKlikken()
  For Each cl In Selection
    c1=ActiveWorkbook.Path & "\Archief " & Format(cells(cl.Row,5), "yyyy") & ".xls"
    
    Workbooks.Add iif(dir(c1)="","",c1)
    
    With ActiveWorkbook
      cl.EntireRow.Copy .Sheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1)
      .SaveAs c1
      .Close
    End With
  Next
End Sub

 

[Roncancio]

In de regel van de foutmelding wordt wel verwezen naar het andere werkblad maar niet naat het bestand zelf.

    CurCell.Rows.EntireRow.Copy [B]Workbooks(ObjWb.Name).[/B]Sheets(ObjWs.Name).Cells(Rows.Count, 2).End(xlUp).Offset(, -1)

Het vetgedrukte gedeelte dient er volgens mij bij te staan.

Met vriendelijke groet,


Roncancio

 

[MeltedForest]

Beide bedankt voor jullie suggesties :thumb:

Verdiep je eerst eens in de basisregels van VBA (gebruik van haakjes bijvoorbeeld).
Gebruik de hulpfunktie van VBA eens vaker. Voorbeeld: entirerow.copy in combinatie met .offset(,-1) (=1 kolom naar links) is 'vreemd'.
Het overnemen van code van anderen is geen bezwaar zolang je de kwaliteit van die code kunt beoordelen en begrijpt wat die doet (en niet alleen beoordelen op resultaat).

Sub Knop11_BijKlikken()
  For Each cl In Selection
    c0="\Archief " & Format(cells(cl.Row,5), "yyyy") & ".xls"
    c1=ThisWorkbook.Path & c0
    
    Workbooks.Add iif(dir(c1)="","",c1)
    
    With ActiveWorkbook
      cl.EntireRow.Copy ActiveWorkbook.Sheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1)
      .SaveAs c1
      .Close
    End With
  Next
End Sub

snb,
ik begrijp de code wel, offset(,-1) komt omdat hij anders het plakken begint bij kolom B, kolom A is een lege kolom in beide bestanden, dus klopt het wel dat het offset(,-1) is.
De toevoeging 1,-1 maakt het helemaal af aangezien het nu daadwerkelijk werkt :thumb:

Ik gebruik de hulpfunctie regelmatig, maar ik word er zelden wijzer van.

 

[Roncancio]

De toevoeging 1,-1 maakt het helemaal af aangezien het nu daadwerkelijk werkt :thumb:

Daar hamert snb nu net op.

Het overnemen van code van anderen is geen bezwaar zolang je de kwaliteit van die code kunt beoordelen en begrijpt wat die doet (en niet alleen beoordelen op resultaat).

Hoe dan ook.
Gaarne de vraag op opgelost zetten.
Bvd.

Met vriendelijke groet,


Roncancio

 

[snb]

Vorige suggestie verbeterd.
Als kolom A in beide bladen leeg is, is 1 kolom opschuiven overbodig.

 

[MeltedForest]

Ik heb uiteindelijk mijn code en snb's code wat gemengd en er kwam het volgende uit:
Ik doe dit even voor toekomstige bezoekers die de zoekfunctie gebruiken :thumb:

Sub Knop11_BijKlikken()
  Dim strFilename As String
  
  'loop rij voor rij de selectie door
  For Each cl In Selection.Rows
    'maak bestandnaam aan adhv datumwaarde in kolom E
    strFilename = ThisWorkbook.Path & "\Archief " & _
    Format(Cells(cl.Row, 5), "yyyy") & ".xls"
    
    'kijk of naam al bestaat in de vorm van bestand
    If Dir(strFilename) <> "" Then
      'als bestand bestaat, open het bestand
      Workbooks.Open (strFilename)
    Else
      'bestaat het niet, maak bestand aan en sla op
      Workbooks.Open (ThisWorkbook.Path & "\Archief Sjabloon.xlt")
      ActiveWorkbook.SaveAs (strFilename)
    End If
    
    'kopieer huidige rij naar archiefbestand en maak rij leeg, sla bestand op en sluit bestand
    With ActiveWorkbook
      cl.EntireRow.Copy ActiveWorkbook.Sheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, -1)
      cl.EntireRow.ClearContents
      .Save
      .Close
    End With
  Next
End Sub

 

[snb]

Workbooks.Open (strFilename)
ActiveWorkbook.SaveAs (strFilename)

Zijn onjuiste VBA codes.

 

[MeltedForest]

Workbooks.Open (strFilename)
ActiveWorkbook.SaveAs (strFilename)

Zijn onjuiste VBA codes.

Wat is er fout aan, aangezien het wel werkt?