waardes kopieren

[don42]

Beste experts,

ik ben al de hele middag bezig met het kopiëren van 4 cellen
naar een rij in het tabblad (facturen)

Private Sub CommandButton6_Click()
Application.ScreenUpdating = False
Dim i As Long
i = Sheets("facturen").Range("A" & Rows.Count).End(xlUp).Row
Sheets("facturen").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = Array([g16], [b15], [n19], [i45])
Application.ScreenUpdating = True
Range("p31").Value = Range("p31").Value + 1
Application.Goto Sheets("facturen").Range("a1")
End Sub

Dat is me uiteindelijk gelukt met bovenstaande code

nu mijn vraag:
Ik zou graag zien dat dit gebeurd met alle sheets die liggen tussen de sheet "start en Herinnering"
dat zijn er op het einde van de maand een 60 stuks

hoop dat het duidelijk is en dat iemand mij kan helpen

Don

 

[edmoor]

Hoe je dat zou moeten doen is je al eerder getoond m.b.t. het verwijderen van die sheets. Dezelfde techniek kan je hier ook voor gebruiken.

http://www.helpmij.nl/forum/showthread.php/887705-Sheets-verwijderen

 

[don42]

Ik heb daar uiteindelijk gekozen voor deze

For Each sh In Sheets
    If sh.Index > Sheets("Start").Index And sh.Index < Sheets("Herinnering").Index Then sh.Delete
Next

daar heb ik natuurlijk aan gedacht maar zie het niet

 

[don42]

komt dit in de buurt

Private Sub CommandButton7_Click()
    For Each sht In ThisWorkbook.Sheets
        Select Case sht.Name
            Case "Start", "Herinnering"
        Case Else
            i = Sheets("facturen").Range("A" & Rows.Count).End(xlUp).Row
Sheets("facturen").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = Array([g16], [b15], [n19], [i45])
        End Select
    Next sht
End Sub

 

[HSV]

Waarom stel je de vraag twee keer?

 

[don42]

Ik stel deze vraag toch geen twee keer
was in eerste instantie van mening dat ik de gegevens van ieder factuur apart naar het tabblad facturen wou sturen
maar dat is zo foutgevoelig, dat ik graag de gegevens aan het einde van de maand wil ophalen
sorry als dit raar overkomt voor jou

 

[HSV]

Dan mijn welgemeende excuses.
Ik had je vorige vraag net beantwoord, en zag diezelfde code hier weer staan, maar net niet tot het laatst doorgelezen.

 

[don42]

stapje verder

HSV ik gebruik je code uit mjn vorige vraag

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Workbooks.Open "d:\bewaren\facturen.xlsx"
  With ActiveWorkbook
   .ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = Array(CDate([g16]), [b15], [n19], [i45])
   .Close 1
  End With
End Sub

Dat werkt echt super, dit zou eigenlijkvoor alle sheets tussen start en herrinering moeten gaan.

 

[HSV]

Wat bedoel je met "tussen".

Hoe staan de tabbladen?
"Start" is de eerste, en "herinnering" is de laatste?

 

[don42]

>start - < herinnering

Nou dat niet er staat 1 tabblad voor start en 2 achter herinnering
met het wissen was de code

For Each sh In Sheets
    If sh.Index > Sheets("Start").Index And sh.Index < Sheets("Herinnering").Index Then sh.Delete
Next

De oplossing.
nu graag de 4 cellen van elk blad naar D:\bewaren\facturen.xlsx

 

[HSV]

Test het zo eens

Private Sub CommandButton2_Click()
dim sh as worksheet
Application.ScreenUpdating = False
Workbooks.Open "d:\bewaren\facturen.xlsx"
  With ActiveWorkbook
   For Each sh In .Sheets
    If sh.Index > Sheets("Start").Index And sh.Index < Sheets("Herinnering").Index Then 
     sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = Array(CDate([g16]), [b15], [n19], [i45])
   .Close 1
  end if
  next sh
  End With
End Sub

 

[don42]

ik krijg nu de melding

Next zonder For

 

[HSV]

Wil wel eens gebeuren als je code schrijft direct in het berichtvenster op het forum.
Ik heb het aangepast in mijn vorig schrijven (end if).

 

[don42]

nu krijg ik deze regel
If sh.Index > Sheets("Start").Index And sh.Index < Sheets("Herinnering").Index Then
als fout melding

 

[HSV]

Met die coderegel ben jezelf gekomen. :d
Zet er eens een punt voor.

[COLOR=#3E3E3E]If sh.Index > [/COLOR][SIZE=4][COLOR=#ff0000].[/COLOR][/SIZE][COLOR=#3E3E3E]Sheets("Start").Index And sh.Index < [/COLOR][SIZE=4][COLOR=#ff0000].[/COLOR][/SIZE][COLOR=#3E3E3E]Sheets("Herinnering").Index Then[/COLOR]

 

[don42]

blijft moeilijk doen
die code komt van Vena
voor verwijden van sheet en werkt super

Sub VenA()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each sh In Sheets
    If sh.Index > Sheets("Start").Index And sh.Index < Sheets("Herinnering").Index Then sh.Delete
Next
Application.DisplayAlerts = True
End Sub

 

[HSV]

Bevat dat werkboek wel die bladnamen?

 

[don42]

Hoe bedoel of die tabbladen werkelijk start en Herinnering heten (dat is zeker zo)

 

[HSV]

Ik heb het maar even nagebootst (wel zo handig).

Private Sub CommandButton2_Click()
Dim sh As Worksheet, Tw As Worksheet
Application.ScreenUpdating = False
Set Tw = ThisWorkbook.Sheets(1)
Workbooks.Open "c:\users\hsv\desktop\map2.xlsx"
  With ActiveWorkbook
   For Each sh In .Sheets
    If sh.Index > .Sheets("Start").Index And sh.Index < .Sheets("Herinnering").Index Then
     MsgBox sh.Name
     sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = Array(CDate(Tw.[g16]), Tw.[b15], Tw.[n19], Tw.[i45])
   End If
  Next sh
  .Close 1
  End With
End Sub

 

[don42]

Goedmorgen
Je hebt er heel wat werk mee zeg
en dan moet ik ook nog zeggen dat de foutmelding onveranderd blijft
nog steeds deze regel in het geel: If sh.Index > .Sheets("Start").Index And sh.Index < .Sheets("Herinnering").Index Then