op weg helpen met vba script

Status
Niet open voor verdere reacties.
A

arjoderoon

Gebruiker
Lid geworden
2 mei 2007
Berichten
476
ik probeer wat ik tot op heden van VBA geleerd heb toe te passen.
Alleen loop ik wat vast.

daarom de vraag of jullie me op weg kunnen helpen:
ik heb 1 worksheet waarop ik vanaf rij 17 in de kolommen A t/m M waarden op wil halen vanuit worksheets met index nummer hoger dan 9.
dus in rij 17 komen de waarden die op worksheet 9 staan
in rij 18 de waarden die op worksheet 10 staan enz.

nu had ik al iets zitten kopieren uit eerdere codes maar ik kom er niet helemaal uit. Ik wil het graag leren dus vandaar mijn vraag of jullie me op weg kunnen helpen:
Code: 
Sub kopiereninadministratie()
Dim ws1 As Worksheet
Dim last As Integer
Dim tb As Integer
Dim t As Integer
Dim cell As Variant

Set ws1 = Worksheets("Administratie")
last = ws1.Range("A17:A" & Rows.Count).End(xlUp).Row
'tb = ActiveWorkbook.Sheets.Count

t = 9

    For Each cell In ws1.Range("A17:A" & CStr(last))

    cell.FormulaR1C1 = Sheets(t).Cells(2, 4)
        
    t = t + 1
    
    Next cell
    

    


End Sub

dit plakt de waarde uit sheet 9, cell D2 in cel A16 (ipv A17).
En ik wil eigenlijk een verwijzing naar cel D2 hebben in plaats van de waarde van uit cel D2.

Welke aanpassing moet ik doorvoeren?
 
Laatst bewerkt door een moderator:
voor het grootste gedeelte werkt het nu.
1 ding krijg ik echter nog niet voor elkaar.

de code zoals de nu is en werkt (op de vetgedrukte regel na)
Code: 
Sub kopiereninadministratie()
Dim ws1 As Worksheet
Dim t As Integer
Dim tb As Integer
Dim tb1 As Integer
Dim tb2 As Integer
Dim cell As Variant
Dim aantalrijen As Integer

Set ws1 = Worksheets("Administratie")

tb = ActiveWorkbook.Sheets.Count
tb1 = 17 + (tb2)
tb2 = tb - 9

With ws1
    If t <= tb1 Then
    For Each cell In ws1.Range("A17:A" & CStr(tb1))
    For t = 0 To tb2
    .Cells(17 + t, 1).Value = Sheets(9 + t).Cells(2, 4)
    Next t
    Next cell
    Else
    End If

    aantalrijen = .Range("A17", .Range("A17").End(xlDown)).Cells.Count
    .Range("B17:B" & aantalrijen + 16) = "=INDIRECT(ADDRESS(4,4,1,,RC[-1]))"
    .Range("C17:C" & aantalrijen + 16) = "=INDIRECT(ADDRESS(5,4,1,,RC[-2]))"
    .Range("D17:D" & aantalrijen + 16) = "=INDIRECT(ADDRESS(6,4,1,,RC[-3]))"
    [b].Range("G17:G" & aantalrijen + 16) = "=INDIRECT(ADDRESS(88,7,1,,RC[-6]))&&INDIRECT(ADDRESS(88,10,1,,RC[-6]))"[/b]
    .Range("H17:H" & aantalrijen + 16) = "=INDIRECT(ADDRESS(88,11,1,,RC[-7]))"
    .Range("I17:I" & aantalrijen + 16) = "=INDIRECT(ADDRESS(95,10,1,,RC[-8]))"
    .Range("J17:J" & aantalrijen + 16) = "=INDIRECT(ADDRESS(5,7,1,,RC[-9]))"
    .Range("K17:K" & aantalrijen + 16) = "=INDIRECT(ADDRESS(1,21,1,,RC[-10]))"
    .Range("L17:L" & aantalrijen + 16) = "=INDIRECT(ADDRESS(2,21,1,,RC[-11]))"
    .Range("M17:M" & aantalrijen + 16) = "=INDIRECT(ADDRESS(3,21,1,,RC[-12]))"
    
End With
    
End Sub

hoe krijg ik in de vetgedrukte regel tussen de beide 'indirect' formules, nog een liggende streepje: - ?
met alles wat ik geprobeerd heb krijg ik een error in vba.
Code: 
"=INDIRECT(ADDRESS(88,7,1,,RC[-6]))&[b]-[/b]&INDIRECT(ADDRESS(88,10,1,,RC[-6]))"

gewoon er tussen zetten lukt niet, met "" om sluiten werkt niet.. ik weet niet waar ik het nu moet zoeken.
 
Plaats dan je document hier eens.
 
De formule heb ik nu opgenomen middels de macro recorder. Dubbele " had ik nog niet geprobeerd, maar bleken de oplossing te zijn.

het volledige script dat ik nu heb:
Code: 
Sub kopiereninadministratie()
Dim ws1 As Worksheet
Dim t As Integer
Dim tb As Integer
Dim tb1 As Integer
Dim tb2 As Integer
Dim cell As Variant
Dim aantalrijen As Integer

Set ws1 = Worksheets("Administratie")

tb = ActiveWorkbook.Sheets.Count
tb1 = 17 + (tb2)
tb2 = tb - 9

With ws1
    If t <= tb1 Then
    For Each cell In ws1.Range("A17:A" & CStr(tb1))
    For t = 0 To tb2
    .Cells(17 + t, 1).Value = Sheets(9 + t).Cells(2, 4)
    Next t
    Next cell
    Else
    End If

    aantalrijen = .Range("A17", .Range("A17").End(xlDown)).Cells.Count
    .Range("B17:B" & aantalrijen + 16) = "=INDIRECT(ADDRESS(4,4,1,,RC[-1]))"
    .Range("C17:C" & aantalrijen + 16) = "=INDIRECT(ADDRESS(5,4,1,,RC[-2]))"
    .Range("D17:D" & aantalrijen + 16) = "=INDIRECT(ADDRESS(6,4,1,,RC[-3]))"
    .Range("G17:G" & aantalrijen + 16) = "=LEFT(INDIRECT(ADDRESS(88,7,1,,RC[-6])),3)& ""-"" &LEFT(INDIRECT(ADDRESS(88,10,1,,RC[-6])),3)"
    .Range("H17:H" & aantalrijen + 16) = "=INDIRECT(ADDRESS(88,11,1,,RC[-7]))"
    .Range("I17:I" & aantalrijen + 16) = "=INDIRECT(ADDRESS(95,10,1,,RC[-8]))"
    .Range("J17:J" & aantalrijen + 16) = "=INDIRECT(ADDRESS(5,7,1,,RC[-9]))"
    .Range("K17:K" & aantalrijen + 16) = "=INDIRECT(ADDRESS(1,21,1,,RC[-10]))"
    .Range("L17:L" & aantalrijen + 16) = "=INDIRECT(ADDRESS(2,21,1,,RC[-11]))"
    .Range("M17:M" & aantalrijen + 16) = "=INDIRECT(ADDRESS(3,21,1,,RC[-12]))"
    
End With
    
End Sub

bij deze regel:
Code: 
    aantalrijen = .Range("A17", .Range("A17").End(xlDown)).Cells.Count

kreeg ik vanmiddag in mijn template een fout aan het einde (terwijl deze eerst wel gewoon werkte).
Fout:
fout 6 overloop

kan dit komen doordat ik aantalrijen als integer heb staan maar dat de count van aantal rijen verder gaat dan de integer parameter kan? In dat geval kan ik aantalrijen beter als long definieren?

overigens: het bestand staat hier:
https://www.dropbox.com/s/drhzwkk10...gsbestand Biohorma WK Voetbal-poule 2014.xlsm
 
Laatst bewerkt:
1 aanvullende vraag nog: pm de worksheets automatisch te laten renamen heb ik deze code nog:
Code: 
If ws.index >= 9 then ws.name = ws.cells(2,4)

Dat werkt perfect totdat de betreffende cel leeg blijkt te zijn. Dan komt er een error:
Fout 1004:
Methode Name van object_worksheet os mislukt

Ik had al als extra toevoeging:
Code: 
If ws.index >= 9 then 
If ws.cells(2,4) = "" then ws.cells(2,4) = "*"
Else
ws.name = ws.cells(2,4)
End if

Maar dat werkt helaas niet. Hoe kan ik dit oplossen?

voor wie het interessant vindt:

ik heb het nu zo opgelost:
Code: 
Sub copyrange()
'kopieert de formules voor punten berekening naar de invulschema's en past de namen van de invulschema's aan

Dim ws As Worksheet
Dim ws1 As Worksheet
Dim cpy As Boolean
Dim last As Integer
Dim tb As Integer
Dim t As Integer

Set ws1 = Worksheets("Max Score")
last = ws1.Range("U" & Rows.Count).End(xlUp).Row

'hulpmiddel om de bron in de sheets te vinden
cpy = False

tb = ActiveWorkbook.Sheets.Count

   If tb < 9 Then Exit Sub
    For t = 9 To tb
    
    Application.ScreenUpdating = False
    
    Sheets(t).Unprotect ("TM")
    [b]If Sheets(t).Cells(2, 4) = "" Then Sheets(t).Cells(2, 4) = "{naam}" & Sheets(t).Index
    
    Sheets(t).Name = Sheets(t).Range("D2").Value [/b]

    If cpy Then
        ws1.Range("U1", "U" & CStr(last)).Copy _
        Destination:=Sheets(t).Range("U1")
        Sheets(t).Range("G5").UnMerge
        ws1.Range("G5").Copy _
        Destination:=Sheets(t).Range("G5")
        Sheets(t).Range("G5:G7").MergeCells = True

    End If
    If Sheets(t).Name = ws1.Name Then        ws1.Range("U1", "U" & CStr(last)).Copy _
        Destination:=Sheets(t).Range("U1")
        Sheets(t).Range("G5").UnMerge
        ws1.Range("G5").Copy _
        Destination:=Sheets(t).Range("G5")
        Sheets(t).Range("G5:G7").MergeCells = True
        cpy = True
        Sheets(t).Protect ("TM")
    End If

Next t

Call kopiereninadministratie

End Sub


Sub kopiereninadministratie()
'vult automatisch het tabblad administratie met de benodigde gegevens

Dim ws1 As Worksheet
Dim t As Integer
Dim tb As Integer
Dim tb1 As Integer
Dim tb2 As Integer
Dim cell As Variant
Dim aantalrijen As Long

Set ws1 = Worksheets("Administratie")

tb = ActiveWorkbook.Sheets.Count
tb1 = 17 + (tb2)
tb2 = tb - 9

With ws1
    If t <= tb1 Then
    For Each cell In ws1.Range("A17:A" & CStr(tb1))
    For t = 0 To tb2
    .Cells(17 + t, 1).Value = Sheets(9 + t).Cells(2, 4)
    Next t
    Next cell
    Else
    End If

    aantalrijen = .Range("A17", .Range("A17").End(xlDown)).Cells.Count
    .Range("B17:B" & aantalrijen + 16) = "=INDIRECT(ADDRESS(4,4,1,,RC[-1]))"
    .Range("C17:C" & aantalrijen + 16) = "=INDIRECT(ADDRESS(5,4,1,,RC[-2]))"
    .Range("D17:D" & aantalrijen + 16) = "=INDIRECT(ADDRESS(6,4,1,,RC[-3]))"
    .Range("G17:G" & aantalrijen + 16) = "=LEFT(INDIRECT(ADDRESS(88,7,1,,RC[-6])),3)& "" - "" &LEFT(INDIRECT(ADDRESS(88,10,1,,RC[-6])),3)"
    .Range("H17:H" & aantalrijen + 16) = "=INDIRECT(ADDRESS(88,11,1,,RC[-7]))"
    .Range("I17:I" & aantalrijen + 16) = "=INDIRECT(ADDRESS(95,10,1,,RC[-8]))"
    .Range("J17:J" & aantalrijen + 16) = "=INDIRECT(ADDRESS(5,7,1,,RC[-9]))"
    .Range("K17:K" & aantalrijen + 16) = "=INDIRECT(ADDRESS(1,21,1,,RC[-10]))"
    .Range("L17:L" & aantalrijen + 16) = "=INDIRECT(ADDRESS(2,21,1,,RC[-11]))"
    .Range("M17:M" & aantalrijen + 16) = "=INDIRECT(ADDRESS(3,21,1,,RC[-12]))"
    
End With
    
End Sub

het enige dat ik nog niet begrijp:
waarom komt:
Code: 
        ws1.Range("U1", "U" & CStr(last)).Copy _
        Destination:=Sheets(t).Range("U1")
        Sheets(t).Range("G5").UnMerge
        ws1.Range("G5").Copy _
        Destination:=Sheets(t).Range("G5")
        Sheets(t).Range("G5:G7").MergeCells = True

na:
Code: 
if cpy then

iemand die mij dat uit kan leggen? die if cpy then stond er nog toen ik ipv sheets(t).index nog ws.index >= 9 had.

edit: met die if cpy then ervoor bleek het niet te werken. Dus is het nu geworden:
Code: 
Sub copyrange()
'kopieert de formules voor punten berekening naar de invulschema's en past de namen van de invulschema's aan

Dim ws As Worksheet
Dim ws1 As Worksheet
Dim cpy As Boolean
Dim last As Integer
Dim tb As Integer
Dim t As Integer

Set ws1 = Worksheets("Max Score")
last = ws1.Range("U" & Rows.Count).End(xlUp).Row

'hulpmiddel om de bron in de sheets te vinden
cpy = False

tb = ActiveWorkbook.Sheets.Count

   If tb < 9 Then Exit Sub
    For t = 9 To tb
    
    Application.ScreenUpdating = False
    
    Sheets(t).Unprotect ("TM")
    If Sheets(t).Cells(2, 4) = "" Then Sheets(t).Cells(2, 4) = "{naam}" & Sheets(t).Index
        Sheets(t).Name = Sheets(t).Range("D2").Value
        ws1.Range("U1", "U" & CStr(last)).Copy _
        Destination:=Sheets(t).Range("U1")
        Sheets(t).Range("G5").UnMerge
        ws1.Range("G5").Copy _
        Destination:=Sheets(t).Range("G5")
        Sheets(t).Range("G5:G7").MergeCells = True
    If Sheets(t).Name = ws1.Name Then
        cpy = True
        Sheets(t).Protect ("TM")
    End If

Next t

Call kopiereninadministratie

End Sub

en dit werkt perfect.
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan