Abgleich von Daten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Stefan,
teste mal:

Option Explicit

Public Sub Abgleich()

    Const WORKBOOK_NAME As String = "to search.xlsx"

    Dim objWorkbook As Workbook, objWorksheet As Worksheet
    Dim objSearchCell As Range, objFindCell As Range
    Dim blnIsOpen As Boolean

    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    For Each objWorkbook In Workbooks
        If objWorkbook.Name = WORKBOOK_NAME Then
            blnIsOpen = True
            Exit For
        End If
    Next

    If Not blnIsOpen Then _
        Set objWorkbook = Workbooks.Open(Filename:= _
        ThisWorkbook.Path & "\" & WORKBOOK_NAME, ReadOnly:=True)

    Set objWorksheet = objWorkbook.Worksheets("Current Week")

    With ThisWorkbook.Worksheets("TUL")

        For Each objSearchCell In .Range(.Cells(2, 7), .Cells(.Rows.Count, 7).End(xlUp))

            If Not IsEmpty(objSearchCell.Value) Then

                Set objFindCell = objWorksheet.Columns(7).Find( _
                    What:=objSearchCell, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)

                If Not objFindCell Is Nothing Then Call objFindCell.Offset(0, 19).Copy( _
                    Destination:=objSearchCell.Offset(0, 11))

            End If
        Next
    End With

    If Not blnIsOpen Then Call objWorkbook.Close(SaveChanges:=False)

    Set objWorksheet = Nothing
    Set objWorkbook = Nothing
    Set objFindCell = Nothing

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Ich bin davon ausgegangen, dass sich beide Mappen im selben Ordner befinden.
Gruß
Nepumuk

Hallo Stefan,
so:

Option Explicit

Public Sub Abgleich()

    Const WORKBOOK_NAME As String = "to search.xlsx"

    Dim objWorkbook As Workbook, objWorksheet As Worksheet
    Dim objSearchCell As Range, objFindCell As Range
    Dim blnIsOpen As Boolean

    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    For Each objWorkbook In Workbooks
        If objWorkbook.Name = WORKBOOK_NAME Then
            blnIsOpen = True
            Exit For
        End If
    Next

    If Not blnIsOpen Then _
        Set objWorkbook = Workbooks.Open(Filename:= _
        ThisWorkbook.Path & "\" & WORKBOOK_NAME, ReadOnly:=True)

    Set objWorksheet = objWorkbook.Worksheets("Current Week")

    With ThisWorkbook.Worksheets("TUL")

        For Each objSearchCell In .Range(.Cells(2, 7), .Cells(.Rows.Count, 7).End(xlUp))

            If Not IsEmpty(objSearchCell.Value) Then

                Set objFindCell = objWorksheet.Columns(7).Find( _
                    What:=objSearchCell, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)

                If Not objFindCell Is Nothing Then
                    Call objFindCell.Offset(0, 19).Copy
                    Call objSearchCell.Offset(0, 11).PasteSpecial(Paste:=xlPasteValuesAndNumberFormats)
                End If

            End If
        Next
    End With

    If Not blnIsOpen Then Call objWorkbook.Close(SaveChanges:=False)

    Set objWorksheet = Nothing
    Set objWorkbook = Nothing
    Set objFindCell = Nothing

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread