• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

vba: wel value maar krijg geen opmaak gekopieerd

Status
Niet open voor verdere reacties.
E

eyeye

Gebruiker
Lid geworden
17 dec 2012
Berichten
42
Hallo,

In samenwerking met Helpmij.nl heb ik een mooie vba-code. Er zit alleen nog een mankement in die ik zelf niet opgelost krijg.

De code zorgt er voor dat een speciefiek range vanuit meerdere excel bestanden naar 1 bestand worden gekopieerd. Echter wordt alleen de waarde van de cellen gekopieerd. Het zou erg handig zijn als ook de opmaak gekopieerd wordt. (het gebeurt namelijk vaak dat in het bronbestanden met kleuren en dikgedrukte cellen gewerkt wordt)

Ik heb al veel info gevonden op internet en m'n VBA-excel boek, maar ik krijg het niet toegpast op mijn bestaande code.

Heeft iemand voor mij de oplossing?

Hierbij de code:
Code: 
Sub inlezen()
     
    Application.DisplayAlerts = False
    week = InputBox("wat is het weeknummer?")
    stPath = ThisWorkbook.Path & "\Binnengekomen planningen\"
    stFile = Dir(stPath & "*.xl*")
    
    If stFile = "" Then MsgBox ("Geen bestanden gevonden in map " & stPath): Exit Sub
    Do While stFile <> ""
        If stFile <> ThisWorkbook.Name Then
            c01 = c01 & stFile & "|" 'opsomming van alle bestanden met | als separator
            stFile = Dir()
        End If
    Loop
    
    stFilename = Split(c01, "|")
    x = 0
    
    For i = 0 To UBound(stFilename) - 1                      '1 voor 1 al die files inlezen
        Application.ScreenUpdating = False
        On Error Resume Next
        Set stFullname = Nothing
        Set stFullname = stPath & Workbooks(stFilename(i))
        Bopen = (Not stFullname Is Nothing)
        
        If Not Bopen Then Set stFullname = Workbooks.Open(stPath & stFilename(i))  'open bestand vestiging als deze nog niet geopend is.
        On Error GoTo 0
        With ThisWorkbook.Sheets("planning")
         .Range("A" & 5 + x * 48).Resize(42, 8).Value = stFullname.Sheets(1).Range("A" & 31 + ((week - 1) * 11)).Resize(42, 8).Value
        End With
        If Not stFullname Is Nothing Then
            If Not Bopen Then stFullname.Close Savechanges:=False  'bestand vestiging sluiten zonder opslaan
        End If
        Application.ScreenUpdating = True
        x = x + 1
    Next
End Sub
 
Misschien werkt dit? Heb er een klein stukje code aan toegevoegd. Kon 't zelf niet testen.....

Gr. Tom

Code: 
Sub inlezen()
     
    Application.DisplayAlerts = False
    week = InputBox("wat is het weeknummer?")
    stPath = ThisWorkbook.Path & "\Binnengekomen planningen\"
    stFile = Dir(stPath & "*.xl*")
    
    If stFile = "" Then MsgBox ("Geen bestanden gevonden in map " & stPath): Exit Sub
    Do While stFile <> ""
        If stFile <> ThisWorkbook.Name Then
            c01 = c01 & stFile & "|" 'opsomming van alle bestanden met | als separator
            stFile = Dir()
        End If
    Loop
    
    stFilename = Split(c01, "|")
    x = 0
    
    For i = 0 To UBound(stFilename) - 1                      '1 voor 1 al die files inlezen
        Application.ScreenUpdating = False
        On Error Resume Next
        Set stFullname = Nothing
        Set stFullname = stPath & Workbooks(stFilename(i))
        Bopen = (Not stFullname Is Nothing)
        
        If Not Bopen Then Set stFullname = Workbooks.Open(stPath & stFilename(i))  'open bestand vestiging als deze nog niet geopend is.
        On Error GoTo 0
        With ThisWorkbook.Sheets("planning")
         .Range("A" & 5 + x * 48).Resize(42, 8).Value = stFullname.Sheets(1).Range("A" & 31 + ((week - 1) * 11)).Resize(42, 8).Value
        End With
 
       'stuk toegevoegd om opmaak te kopieren
       stFullname.Sheets(1).Range("A" & 31 + ((week - 1) * 11)).Resize(42, 8).copy
       ThisWorkbook.Sheets("planning").Range("A" & 5 + x * 48).Resize(42, 8).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone,SkipBlanks:=False, Transpose:=False
       Application.CutCopyMode = False


        If Not stFullname Is Nothing Then
            If Not Bopen Then stFullname.Close Savechanges:=False  'bestand vestiging sluiten zonder opslaan
        End If
        Application.ScreenUpdating = True
        x = x + 1
    Next
End Sub
 
Laatst bewerkt:
Tom, bedankt!

Het werkt goed!

Komt natuurlijk een vervolg vraag:
Ik heb ook een sub voor het terugschrijven van de gegevens (nadat ik wijzigingen heb gemaakt). Ook daarbij zou ik graag de opmaak mee kopieren.
Ik heb geprobeerd jou toevoeging ook daarin te zetten, maar dat werkt niet. Heb je ook hiervoor een oplossing?

hierbij de code voor het terugzetten van de cellen:

Code: 
Sub uitlezen()
Dim fname As String 'benoeming van de term fname toegevoegd'

    Application.DisplayAlerts = False
    week = ThisWorkbook.Sheets("planning").Range("A5").Value
    stPath = ThisWorkbook.Path & "\Binnengekomen planningen\"
    stFile = Dir(stPath & "*.xl*")
    
    If stFile = "" Then MsgBox ("Geen bestanden gevonden in map " & stPath): Exit Sub
    Do While stFile <> ""
        If stFile <> ThisWorkbook.Name Then
            c01 = c01 & stFile & "|" 'opsomming van alle bestanden met | als separator
            stFile = Dir()
        End If
    Loop
    
    stFilename = Split(c01, "|")
    x = 0
    
    For i = 0 To UBound(stFilename) - 1                      '1 voor 1 al die files inlezen
        Application.ScreenUpdating = False
        On Error Resume Next
        Set stFullname = Nothing
        Set stFullname = stPath & Workbooks(stFilename(i))
        Bopen = (Not stFullname Is Nothing)
        
        If Not Bopen Then Set stFullname = Workbooks.Open(stPath & stFilename(i))  'open bestand vestiging als deze nog niet geopend is.
        On Error GoTo 0
        With stFullname.Sheets(1)
        .Unprotect Password:="1234" 'van het bestand wat geopend word de beveiliging afgehaald'
        Set vestiging = ThisWorkbook.Sheets("planning").Range("A:A").SpecialCells(2).Find(.Range("A32").Value, lookat:=xlWhole)
        Set c = .Range("A:A").Find(week, lookat:=xlWhole)
        .Cells(c.Row, 1).Resize(42, 8).Value = ThisWorkbook.Sheets("planning").Range(vestiging.Address).Offset(-1).Resize(42, 8).Value
        .Protect Password:="1234" 'de geopende bestanden worden weer beveiligd met het zelfde wachtwoord'
        End With
        
        
        If Not stFullname Is Nothing Then
            If Not Bopen Then stFullname.Close Savechanges:=True  'bestand vestiging sluiten en opslaan
        End If
        Application.ScreenUpdating = True
        x = x + 1
    Next


End Sub
 
aanpassing voor beide macro's zodat opmaak en waarden gekopieerd worden.

Code: 
Sub uitlezen()
Dim fname As String 'benoeming van de term fname toegevoegd'

    Application.DisplayAlerts = False
    week = ThisWorkbook.Sheets("planning").Range("A5").Value
    stPath = ThisWorkbook.Path & "\Binnengekomen planningen\"
    stFile = Dir(stPath & "*.xl*")
    
    If stFile = "" Then MsgBox ("Geen bestanden gevonden in map " & stPath): Exit Sub
    Do While stFile <> ""
        If stFile <> ThisWorkbook.Name Then
            c01 = c01 & stFile & "|" 'opsomming van alle bestanden met | als separator
            stFile = Dir()
        End If
    Loop
    
    stFilename = Split(c01, "|")
    x = 0
    
    For i = 0 To UBound(stFilename) - 1                      '1 voor 1 al die files inlezen
        Application.ScreenUpdating = False
        On Error Resume Next
        Set stFullname = Nothing
        Set stFullname = stPath & Workbooks(stFilename(i))
        Bopen = (Not stFullname Is Nothing)
        
        If Not Bopen Then Set stFullname = Workbooks.Open(stPath & stFilename(i))  'open bestand vestiging als deze nog niet geopend is.
        On Error GoTo 0
        With stFullname.Sheets(1)
        .Unprotect Password:="1234" 'van het bestand wat geopend word de beveiliging afgehaald'
        Set vestiging = ThisWorkbook.Sheets("planning").Range("A:A").SpecialCells(2).Find(.Range("A32").Value, lookat:=xlWhole)
        Set c = .Range("A:A").Find(week, lookat:=xlWhole)
        [COLOR="#FF0000"]ThisWorkbook.Sheets("planning").Range(vestiging.Address).Offset(-1).Resize(42, 8).Copy .Cells(c.Row, 1).Resize(42, 8)[/COLOR]
        .Protect Password:="1234" 'de geopende bestanden worden weer beveiligd met het zelfde wachtwoord'
        End With
        
        
        If Not stFullname Is Nothing Then
            If Not Bopen Then stFullname.Close Savechanges:=True  'bestand vestiging sluiten en opslaan
        End If
        Application.ScreenUpdating = True
        x = x + 1
    Next


End Sub

Code: 
Sub inlezen()
     
    Application.DisplayAlerts = False
    week = InputBox("wat is het weeknummer?")
    stPath = ThisWorkbook.Path & "\Binnengekomen planningen\"
    stFile = Dir(stPath & "*.xl*")
    
    If stFile = "" Then MsgBox ("Geen bestanden gevonden in map " & stPath): Exit Sub
    Do While stFile <> ""
        If stFile <> ThisWorkbook.Name Then
            c01 = c01 & stFile & "|" 'opsomming van alle bestanden met | als separator
            stFile = Dir()
        End If
    Loop
    
    stFilename = Split(c01, "|")
    x = 0
    
    For i = 0 To UBound(stFilename) - 1                      '1 voor 1 al die files inlezen
        Application.ScreenUpdating = False
        On Error Resume Next
        Set stFullname = Nothing
        Set stFullname = stPath & Workbooks(stFilename(i))
        Bopen = (Not stFullname Is Nothing)
        
        If Not Bopen Then Set stFullname = Workbooks.Open(stPath & stFilename(i))  'open bestand vestiging als deze nog niet geopend is.
        On Error GoTo 0
        With ThisWorkbook.Sheets("planning")
         [COLOR="#FF0000"]stFullname.Sheets(1).Range("A" & 31 + ((week - 1) * 11)).Resize(42, 8).Copy .Range("A" & 5 + x * 48).Resize(42, 8)[/COLOR]
        End With
        If Not stFullname Is Nothing Then
            If Not Bopen Then stFullname.Close Savechanges:=False  'bestand vestiging sluiten zonder opslaan
        End If
        Application.ScreenUpdating = True
        x = x + 1
    Next
End Sub


Niels
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan