macro werkt niet goed

[shkipper]

Hello

Ik heb hier een kleine probleem met mijn macro.

Dus wat ik wil is kopieren data van ene xls sheet en merg met andere data en in een andere xls inzetten.

Maar probleem is, is dat ik een fout krijg of soms als het werkt de derde resultaten xls is leeg, en met leeg bedoel ik dat daar zitten geen sheets in

 Sub auto_close()

Dim linkSrcFile As String
Dim targetSrcFile As String

Dim currentFilePath As String

Dim wkbLink As Workbook
Dim targetWkb As Workbook

Dim wksLinkWkb As Worksheet 'Link document
Dim wksCurrent As Worksheet 'Current
Dim targetWks As Worksheet 'Target = Results

'Dim currentWks As Worksheet
Dim docname As String
Dim user As String

'File names
Dim linkDoc As String
Dim resultDoc As String

linkDoc = "Link document.xls"
resultDoc = "Results.xls"

'On Error GoTo ErrorHandling

'Set Paths
linkSrcFile = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, linkDoc)
targetSrcFile = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, resultDoc)

'Get workbooks
Set wkbLink = GetObject(linkSrcFile)
Set targetWkb = GetObject(targetSrcFile)

'Get worksheets
Set wksLinkWkb = wkbLink.Worksheets("Sheet1")
Set wksCurrent = ThisWorkbook.Worksheets("Sheet1")
Set targetWks = targetWkb.Worksheets("Sheet1")

Dim nbColumns As Integer
Dim nbForUnhiddenColumn As Integer

'Determing the amount of columns
nbColumns = Range("1:1").Cells.SpecialCells(xlCellTypeConstants).Count

'Checking for unhidden column
For i = 1 To nbColumns
    If Columns(i).Hidden = False Then
        Debug.Print "Column is not hidden"
        nbForUnhiddenColumn = i
        Exit For
    End If
Next i

'First row
'wksCurrent.Range("A1", "P1").Copy
wksCurrent.Range(Cells(1, 1), Cells(1, 16)).Copy
targetWks.Range("A1", "P1").PasteSpecial (xlPasteAll)
targetWks.Range("Q1").Value = "User"

'Looping thru the records in Link xls file
For i = 2 To wksLinkWkb.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

    docname = wksLinkWkb.Cells(i, 3).Value
    user = wksLinkWkb.Cells(i, 2).Value

        'Looping thru Report.xls records
        For j = 2 To wksCurrent.Range(nbForUnhiddenColumn & ":" & nbForUnhiddenColumn).Cells.SpecialCells(xlCellTypeConstants).Count
            If wksCurrent.Cells(j, "J").Value = docname Then
                Debug.Print "Match " & docname & " " & user
                wksCurrent.Range(Cells(j, 1), Cells(j, nbColumns)).Copy
                targetWks.Range(Cells(i, 1), Cells(i, nbColumns)).PasteSpecial (xlPasteAll)
                targetWks.Cells(i, nbColumns + 1).Value = user
                Exit For
            End If
        Next j
Next i

targetWkb.Save
targetWkb.Close
wkbLink.Close False
Debug.Print "Target workbook saved and closed"

Exit_thisSub:
    Exit Sub

ErrorHandling:
    Dim strMsg As String
    Select Case Err.Number
        Case 432
            strMsg = "Error occured: Make sure the names of the files are correct: " & linkDoc & " and " & resultDoc & " and they are in the same map, as this one (" & ThisWorkbook.Name & ")"
            MsgBox strMsg
            targetWkb.Close False
            wkbLink.Close False
        Case Else
            strMsg = "Error occured: " & Err.Number & " " & Err.Description
            MsgBox strMsg
            targetWkb.Close False
            wkbLink.Close False
    End Select
    Exit Sub

End Sub

Dus ik stel voor als iemand kan testen en misschien zeggen wat ik precies mis, ik zou echt tof vinden.
Want ik kan echt de fout niet vinden

 

[huijb]

We zijn een Nederlands forum denk daaraan bij het bedenken van een titel. Topictitel aangepast.

 

[shkipper]

ja, sorry voor de engels titel.

nog wat extra uitleg:

dus wat ik doe is:
feerst het haalt all objecten

Dan ga ik eerst een eerste record kopieren en dan naar de target pasten. Tot daar werkt het perfect.

Dan ga ik via loop, 1 voor 1 record kopieren en plakken (gebruik makend van link xls(if))
naar de result xls file.

En dan heb ik ook de error handling, maar dat is niet zo belangrijk

 

[Mark xl]

beginnersfout 1:
altijd bij een Range object zorgen dat je ook naar het jusite workbook/worksheet object refereert.

Deze fout komt wel een aantal malen voor.
Probeer die eruit te halen en kijk dan waar nog fouten optreden.

    'Determing the amount of columns
    nbColumns = Range("1:1").Cells.SpecialCells(xlCellTypeConstants).Count

welk blad? welke werkmap?

en dat geldt ook voor deze:

wksCurrent.Range(Cells(1, 1), Cells(1, 16))

Je refereert hier naar wksCurrent.Range, maar als wkscurrent niet actief is krijg je een fout op, omdat je ook expliciet het werkblad van Cells(1,1) en cells(1,16) moet benoemen.

wat je in die regel daaronder doet is wel correcte verwijzing, nl:

targetWks.Range("A1", "P1")

verder vraag ik me af wat de reden is dat je cellen telt zoals bijvoorbeeld:

wksLinkWkb.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

Dit is erg foutgevoelig. als je in plaats daarvan een paar regels code meer moet gaan gebruiken, het zij zo.
maak er eventueel een aparte functie voor.

succes,

Mark.

 

[shkipper]

Ik heb wat aanpassingen gedaan, als ik het laat runnen, krijg ik geen fouten maar er is ook geen resultaat, dat wilt zeggen dat mijn result.xls is gewoon leeg, en met leeg bedoel ik echt dar als ik het open, is alles grijs en er zijn geen werkbladen ezv ...
Wat zou dit probleem kunnen veroorzaken

Ik heb hier ook dit aanpassing gedaan: is het beter?

wksCurrent.Range(Cells(j, 1), Cells(j, nbColumns)).Copy Destination:=targetWks.Range("A1:P1").Offset(i, 0)

of zou ik zo laten:

                wksCurrent.Activate
                wksCurrent.Range(Cells(j, 1), Cells(j, nbColumns)).Copy
                targetWks.Activate
                targetWks.Cells(i, 1).PasteSpecial (xlPasteAll)
                targetWks.Cells(i, nbColumns + 1).Value = user

Wat ik ook probeer te doen is niet hard coderen zodat als extra kolom bij komt krijg ik geen fout en alles wordt toch gekopieerd

 

[Mark xl]

Dat is heel goed.

Volstaat het om in plaats van cellen met constanten te tellen
de waarde van de laatst gevulde rij (of kolom) van het werkblad te nemen?

met die info kan ik de macro wel voor je aanpassen.

 

[shkipper]

Yep, dat volstaat

Maar ik moet wel uiteindelijk de waarden in mij result.xls krijgen anders momenteel die is constant leeg, wat ik ook al doe, en ik krijg geen erros bij het uitvoeren van macro. Maar de oplossing zou prachtig zijn ...

 

[Mark xl]

Ik heb je code wat omgegooid om het voor mezelf wat duidelijker te maken.

hopelijk vind jij dat ook

Ook heb ik wat code die niet voor het gehele verloop van de macro vereist waren naar aparte procedures gehaald.
daar valt nog wel meer winst te halen denk ik, maar dat komt vanzelf.

waar loop je nu nog tegenaan?

Option Explicit

Sub auto_close()

    'File names
    Const LINKDOC As String = "Link document.xls"
    Const RESULTDOC As String = "Results.xls"
    
    Dim row As Long             'the rownumber for the loop
        
    Dim numberOfRows As Long            'the number of rows in the link sheets
    Dim firstColumn As Long             'the first visible column
    Dim lastColumn As Long
    
    Dim documentData As Variant           'Holds array with data of all documents
    Dim document As Range               'refers to a cell with the document name
    
    Dim targetBook As Workbook          'the report workbook
    
    Dim currentSheet As Worksheet       'Current sheet
    Dim targetSheet As Worksheet        'Target = Results
    
    Dim documentName As String          'the name of the current document
    Dim userName As String
    
    Dim errorMessage As String
    
    On Error GoTo ErrorHandling:
    
    Set targetBook = Workbooks.Open(ThisWorkbook.Path & "\" & RESULTDOC)
    
    '   Get worksheets
    Set currentSheet = ThisWorkbook.Worksheets("Sheet1")
    Set targetSheet = targetBook.Worksheets("Sheet1")

    '   Checking for unhidden column
    firstColumn = GetFirstVisibleColumn(currentSheet)
    '   get the last column on the current sheet
    lastColumn = currentSheet.Range("IV1").End(xlToLeft).column

    '   copy headers to targetsheet
    currentSheet.Range("A1").Resize(, lastColumn).Copy Destination:=targetSheet.Range("A1")
    
    '   add a column for "user" on the targetsheet
    targetSheet.Range("A1").Offset(, lastColumn) = "User"
    
    '   get the documentData by passing the name of the linkdocument to the getlinkinfo() function below
    documentData = GetLinkInfo(ThisWorkbook.Path & "\" & LINKDOC)
    
    '   number of rows in documentData, -1 with empty result
    numberOfRows = UBound(documentData)
    
    '   check all links, skip first row with headers
    For row = 2 To numberOfRows
        
        'read the documentname
        documentName = documentData(row, 3).Value
     
        With currentSheet.columns(firstColumn & ":" & firstColumn)
            
            'preform a CASE SENSITIVE search on the currentsheet firstcolumn to find documentname
            Set document = .Find(What:=documentName, _
                                LookIn:=xlValues, _
                                Lookat:=xlWhole, _
                                MatchCase:=True)    ' << set to false for CASE INSENSITIVE search,
                                                    '    which might improve your match rate :-)
        
        End With
         
        If Not document Is Nothing Then
        
            'if the documentname is found...
            'read the username
            userName = documentData(row, 2).Value
            
            'copy with all formats to the targetsheet
            currentSheet.Range("A" & document.row).Resize(, lastColumn).Copy _
                            Destination:=targetSheet.Range("A" & row)
            'write the username
            targetSheet.Range("A" & row).Offset(, lastColumn) = userName
            
        Else
            'document not found
            Debug.Print "het document " & documentName & " is niet gevonden"
            
        End If
             
    Next row
    
    'success! save the workbook
    targetBook.Save
    
    Debug.Print "Target workbook saved"
    
    On Error GoTo 0
    
ErrorHandling:

    Select Case Err.Number
    
        Case 0      'no errors
    
        Case 432
        
            'file not found error
            errorMessage = "An Error occured: Make sure the names of the files are correct: " & _
                            LINKDOC & " and " & RESULTDOC & " and they are in the same folder" & _
                            " as this one (" & ThisWorkbook.Path & ")"
            MsgBox errorMessage
            
        Case Else
            errorMessage = "Error occured: " & Err.Number & " " & Err.Description
            MsgBox errorMessage
            
    End Select
    
    'clear errors
    Err.Clear
    
    closeWorkbookObject targetBook
    
    'destroy objects
    Set targetBook = Nothing
    Set currentSheet = Nothing
    Set targetSheet = Nothing
    
End Sub

Private Function GetFirstVisibleColumn(ByVal Sheet As Excel.Worksheet) As Long
'returns the number of the first visible column on "sheet"
Dim column As Long      'the column track for the loop
Dim columnCount As Long 'the total number of columns to check
    
    columnCount = Sheet.Range("IV1").End(xlToLeft).column
    
    For column = 1 To columnCount

        If Sheet.columns(column).Hidden = False Then
        
            GetFirstVisibleColumn = column
            Exit For
            
        End If
        
    Next column
    
End Function

Private Function GetLinkInfo(ByVal Linkworkbookname As String) As Variant
'haal documentnaam + gebruiker op uit het gespecificeerde document
'   en geef deze als array terug aan de aanroeper van de functie
Dim linkbook As Excel.Workbook
Dim rowCount As Long

    On Error GoTo ErrHandle:

    Set linkbook = Workbooks.Open(Linkworkbookname)
    
    'this can also be changed to worksheets(1) if the name can differ
    With linkbook.Worksheets("Sheet1")
            
        rowCount = .Range("A65535").End(xlUp).row
        '   Save Documentdata to array
        GetLinkInfo = .Range("A1:C1").Resize(rowCount)
        
    End With
    
    On Error GoTo 0
    
ErrHandle:
    
    If Err.Number <> 0 Then
        'something went wrong,return empty result:
        GetLinkInfo = Array()
    End If
    
    'close the link book, and free up resources
    closeWorkbookObject linkbook
    
    Set linkbook = Nothing

End Function

Private Sub closeWorkbookObject(ByVal wb As Excel.Workbook)

    If Not wb Is Nothing Then
        wb.Close False
    End If
    
End Sub

 

[shkipper]

Ja, prachtige code
Maar ja, wat de bedoeling is, is dat de link document.xls wordt ook geopend en aan de hand van de 3columnt the waardes daarvan, wordt in de current document gezocht en als er match is, wordt naar de derde doc gekopieerd.

In jouw code wordt het niet gedaan

Dus met andere worden er moet een geneste loop zijn.

 

[Mark xl]

Nee dat hoeft niet.

De geneste loop in de door jouw geposte voorbeeld is niets meer dan een inefficiënte zoekfunctie, want de geneste loop wordt afgebroken bij het vinden van een match.

maargoed, ik zocht dus niet in kolom J, dus nu zou het beter moeten lukken met deze code. ik kan hier alleen helaas niet testen, vandaar.

Option Explicit

Sub auto_close()

    'File names
    Const LINKDOC As String = "Link document.xls"
    Const RESULTDOC As String = "Results.xls"
    
    Dim row As Long             'the rownumber for the loop
        
    Dim numberOfRows As Long            'the number of rows in the link sheets
    Dim firstColumn As Long             'the first visible column
    Dim lastColumn As Long
    
    Dim documentData As Variant           'Holds array with data of all documents
    Dim document As Range               'refers to a cell with the document name
    
    Dim targetBook As Workbook          'the report workbook
    
    Dim currentSheet As Worksheet       'Current sheet
    Dim targetSheet As Worksheet        'Target = Results
    
    Dim documentName As String          'the name of the current document
    Dim userName As String
    
    Dim errorMessage As String
    
    On Error GoTo ErrorHandling:
    
    Set targetBook = Workbooks.Open(ThisWorkbook.Path & "\" & RESULTDOC)
    
    '   Get worksheets
    Set currentSheet = ThisWorkbook.Worksheets("Sheet1")
    Set targetSheet = targetBook.Worksheets("Sheet1")

    '   Checking for unhidden column
    firstColumn = GetFirstVisibleColumn(currentSheet)
    '   get the last column on the current sheet
    lastColumn = currentSheet.Range("IV1").End(xlToLeft).column

    '   copy headers to targetsheet
    currentSheet.Range("A1").Resize(, lastColumn).Copy Destination:=targetSheet.Range("A1")
    
    '   add a column for "user" on the targetsheet
    targetSheet.Range("A1").Offset(, lastColumn) = "User"
    
    '   get the documentData by passing the name of the linkdocument to the getlinkinfo() function below
    documentData = GetLinkInfo(ThisWorkbook.Path & "\" & LINKDOC)
    
    '   number of rows in documentData, -1 with empty result
    numberOfRows = UBound(documentData)
    
    '   check all links, skip first row with headers
    For row = 2 To numberOfRows
        
        'read the documentname
        documentName = documentData(row, 3).Value
     
        With currentSheet.columns("J")
            
            'preform a CASE SENSITIVE search on the currentsheet firstcolumn to find documentname
            Set document = .Find(What:=documentName, _
                                LookIn:=xlValues, _
                                Lookat:=xlWhole, _
                                MatchCase:=True)    ' << set to false for CASE INSENSITIVE search,
                                                    '    which might improve your match rate :-)
        
        End With
         
        If Not document Is Nothing Then
        
            'if the documentname is found...
            'read the username
            userName = documentData(row, 2).Value
            
            'copy with all formats to the targetsheet
            currentSheet.Range("A" & document.row).Resize(, lastColumn).Copy _
                            Destination:=targetSheet.Range("A" & row)
            'write the username
            targetSheet.Range("A" & row).Offset(, lastColumn) = userName
            
        Else
            'document not found
            Debug.Print "het document " & documentName & " is niet gevonden"
            
        End If
             
    Next row
    
    'success! save the workbook
    targetBook.Save
    
    Debug.Print "Target workbook saved"
    
    On Error GoTo 0
    
ErrorHandling:

    Select Case Err.Number
    
        Case 0      'no errors
    
        Case 432
        
            'file not found error
            errorMessage = "An Error occured: Make sure the names of the files are correct: " & _
                            LINKDOC & " and " & RESULTDOC & " and they are in the same folder" & _
                            " as this one (" & ThisWorkbook.Path & ")"
            MsgBox errorMessage
            
        Case Else
            errorMessage = "Error occured: " & Err.Number & " " & Err.Description
            MsgBox errorMessage
            
    End Select
    
    'clear errors
    Err.Clear
    
    closeWorkbookObject targetBook
    
    'destroy objects
    Set targetBook = Nothing
    Set currentSheet = Nothing
    Set targetSheet = Nothing
    
End Sub

Private Function GetFirstVisibleColumn(ByVal Sheet As Excel.Worksheet) As Long
'returns the number of the first visible column on "sheet"
Dim column As Long      'the column track for the loop
Dim columnCount As Long 'the total number of columns to check
    
    columnCount = Sheet.Range("IV1").End(xlToLeft).column
    
    For column = 1 To columnCount

        If Sheet.columns(column).Hidden = False Then
        
            GetFirstVisibleColumn = column
            Exit For
            
        End If
        
    Next column
    
End Function

Private Function GetLinkInfo(ByVal Linkworkbookname As String) As Variant
'haal documentnaam + gebruiker op uit het gespecificeerde document
'   en geef deze als array terug aan de aanroeper van de functie
Dim linkbook As Excel.Workbook
Dim rowCount As Long

    On Error GoTo ErrHandle:

    Set linkbook = Workbooks.Open(Linkworkbookname)
    
    'this can also be changed to worksheets(1) if the name can differ
    With linkbook.Worksheets("Sheet1")
            
        rowCount = .Range("A65535").End(xlUp).row
        '   Save Documentdata to array
        GetLinkInfo = .Range("A1:C1").Resize(rowCount)
        
    End With
    
    On Error GoTo 0
    
ErrHandle:
    
    If Err.Number <> 0 Then
        'something went wrong,return empty result:
        GetLinkInfo = Array()
    End If
    
    'close the link book, and free up resources
    closeWorkbookObject linkbook
    
    Set linkbook = Nothing

End Function

Private Sub closeWorkbookObject(ByVal wb As Excel.Workbook)

    If Not wb Is Nothing Then
        wb.Close False
    End If
    
End Sub

 

[shkipper]

Ok, maar nog steeds kom ik vast bij dit regel: documentName = documentData(row, 3).Value
Het zegt 'Object required, error 424'

 

[Mark xl]

AHA. dat klopt inderdaad want het moet zijn documentName = documentData(row, 3)

fout van mij. dat krijg je ervan zonder testen
hier weer de aangepaste code

we komen in de buurt denk ik.

Sub auto_close()

    'File names
    Const LINKDOC As String = "Link document.xls"
    Const RESULTDOC As String = "Results.xls"
    
    Dim row As Long             'the rownumber for the loop
        
    Dim numberOfRows As Long            'the number of rows in the link sheets
    Dim firstColumn As Long             'the first visible column
    Dim lastColumn As Long
    
    Dim documentData As Variant           'Holds array with data of all documents
    Dim document As Range               'refers to a cell with the document name
    
    Dim targetBook As Workbook          'the report workbook
    
    Dim currentSheet As Worksheet       'Current sheet
    Dim targetSheet As Worksheet        'Target = Results
    
    Dim documentName As String          'the name of the current document
    Dim userName As String
    
    Dim errorMessage As String
    
    On Error GoTo ErrorHandling:
    
    Set targetBook = Workbooks.Open(ThisWorkbook.path & "\" & RESULTDOC)
    
    '   Get worksheets
    Set currentSheet = ThisWorkbook.Worksheets("Sheet1")
    Set targetSheet = targetBook.Worksheets("Sheet1")

    '   Checking for unhidden column
    firstColumn = GetFirstVisibleColumn(currentSheet)
    '   get the last column on the current sheet
    lastColumn = currentSheet.Range("IV1").End(xlToLeft).column

    '   copy headers to targetsheet
    currentSheet.Range("A1").Resize(, lastColumn).Copy Destination:=targetSheet.Range("A1")
    
    '   add a column for "user" on the targetsheet
    targetSheet.Range("A1").Offset(, lastColumn) = "User"
    
    '   get the documentData by passing the name of the linkdocument to the getlinkinfo() function below
    documentData = GetLinkInfo(ThisWorkbook.path & "\" & LINKDOC)
    
    '   number of rows in documentData, -1 with empty result
    numberOfRows = UBound(documentData)
    
    '   check all links, skip first row with headers
    For row = 2 To numberOfRows
        
        'read the documentname
        documentName = documentData(row, 3)
     
        With currentSheet.Columns("J")
            
            'preform a CASE SENSITIVE search on the currentsheet firstcolumn to find documentname
            Set document = .Find(What:=documentName, _
                                LookIn:=xlValues, _
                                Lookat:=xlWhole, _
                                MatchCase:=True)    ' << set to false for CASE INSENSITIVE search,
                                                    '    which might improve your match rate :-)
        
        End With
         
        If Not document Is Nothing Then
        
            'if the documentname is found...
            'read the username
            userName = documentData(row, 2)
            
            'copy with all formats to the targetsheet
            currentSheet.Range("A" & document.row).Resize(, lastColumn).Copy _
                            Destination:=targetSheet.Range("A" & row)
            'write the username
            targetSheet.Range("A" & row).Offset(, lastColumn) = userName
            
        Else
            'document not found
            Debug.Print "het document " & documentName & " is niet gevonden"
            
        End If
             
    Next row
    
    'success! save the workbook
    targetBook.Save
    
    Debug.Print "Target workbook saved"
    
    On Error GoTo 0
    
ErrorHandling:

    Select Case Err.Number
    
        Case 0      'no errors
    
        Case 432
        
            'file not found error
            errorMessage = "An Error occured: Make sure the names of the files are correct: " & _
                            LINKDOC & " and " & RESULTDOC & " and they are in the same folder" & _
                            " as this one (" & ThisWorkbook.path & ")"
            MsgBox errorMessage
            
        Case Else
            errorMessage = "Error occured: " & Err.Number & " " & Err.Description
            MsgBox errorMessage
            
    End Select
    
    'clear errors
    Err.Clear
    
    closeWorkbookObject targetBook
    
    'destroy objects
    Set targetBook = Nothing
    Set currentSheet = Nothing
    Set targetSheet = Nothing
    
End Sub

Private Function GetFirstVisibleColumn(ByVal Sheet As Excel.Worksheet) As Long
'returns the number of the first visible column on "sheet"
Dim column As Long      'the column track for the loop
Dim columnCount As Long 'the total number of columns to check
    
    columnCount = Sheet.Range("IV1").End(xlToLeft).column
    
    For column = 1 To columnCount

        If Sheet.Columns(column).Hidden = False Then
        
            GetFirstVisibleColumn = column
            Exit For
            
        End If
        
    Next column
    
End Function

Private Function GetLinkInfo(ByVal Linkworkbookname As String) As Variant
'haal documentnaam + gebruiker op uit het gespecificeerde document
'   en geef deze als array terug aan de aanroeper van de functie
Dim linkbook As Excel.Workbook
Dim rowCount As Long

    On Error GoTo ErrHandle:

    Set linkbook = Workbooks.Open(Linkworkbookname)
    
    'this can also be changed to worksheets(1) if the name can differ
    With linkbook.Worksheets("Sheet1")
            
        rowCount = .Range("A65535").End(xlUp).row
        '   Save Documentdata to array
        GetLinkInfo = .Range("A1:C1").Resize(rowCount)
        
    End With
    
    On Error GoTo 0
    
ErrHandle:
    
    If Err.Number <> 0 Then
        'something went wrong,return empty result:
        GetLinkInfo = Array()
    End If
    
    'close the link book, and free up resources
    closeWorkbookObject linkbook
    
    Set linkbook = Nothing

End Function

Private Sub closeWorkbookObject(ByVal wb As Excel.Workbook)

    If Not wb Is Nothing Then
        wb.Close False
    End If
    
End Sub

 

[shkipper]

Ja, bedankt, het werkt en zeer mooi geschreven!

Wat ik had natuurlijk was een beetje chaotisch )

 

[shkipper]

Hello mark ik zou je nog iets willen vragen

Deze macro ... is het extensible ... darmee bedoel ik stel voor als ik de code ga kopieren naar andere xl bestand, zal het dan ook werken?

De nieuwe excel bestand kan vb meer of minder kolommen hebben?

En weet je ik heb weer jouw hulp nodig met nog iets.
NL

Wat ik heb is 3 sheets met data, met juist dezelfde data ...
Dus als ik op ene sheet iets verander moeten ook de andere sheets aangepast worden.
De probleem die ik krijg is dat als er stel voor op ene sheet is wordt een rijd verwijderd, kan ik op andere dat niet uitvoeren.
Ik heb geprobeerd om een loop te maken om de resten die niet nodig waren te verwijderen maar dat lukt niet .. en dat heeft iets te maken met dat de gegevens is in een lijst gemaakt en moet gesincroniseerd worden.

Ik zal hier de code plaatsen, als je die kunt effe bekijken en misschien helpen.

Public Sub Duplicate()

Dim activeSheet As Worksheet
Dim s As Worksheet

Set activeSheet = ThisWorkbook.activeSheet
        
Dim RowCount As Integer
Dim CollCount As Integer
Dim name As String


RowCount = activeSheet.UsedRange.rows.Count
CollCount = activeSheet.UsedRange.columns.Count
name = activeSheet.name

        Range(Cells(2, 2), Cells(RowCount, CollCount)).Select
        Selection.Copy

For Each s In ThisWorkbook.Worksheets
    'If s.Name <> activeSheet.Name Then
    '/Sheets(activeSheet).Select
    If s.name <> name Then
        Sheets(s.name).Select
        Range(Cells(2, 2), Cells(RowCount, CollCount)).Select
        Selection.PasteSpecial (xlPasteAll)

    End If
    Next s


    

End Sub

Sub Synchronization()

Dim CellIsATable As Boolean
Dim s As Worksheet
    
For Each s In ThisWorkbook.Worksheets
    s.Activate
    s.Cells(1, 1).Select
    CellIsATable = (Selection.ListObject.name <> "")
    
    If (CellIsATable = True) Then
        Selection.ListObject.UpdateChanges
    Else
        MsgBox "The selected cell is not a part of the list"
    End If
Next s

End Sub

Dus in het algemeen wil ik dat de macro gaat eerst alle tabbladen dupliceren, zodat zij allemaal hetzelfde zijn en dan synchroniseren met sharepoint.

Dus de probleem is dat ik niet kan gemakkelijk record verwijderen na dat ik van excel sheet lijst heb gemaakt en gepublished.