How to import values based on week number criteria from a closed workbook to an active workbook

[igor_majer]

How to extract data from closed Workbook into active Workbook based on ISO week number criteria? In closed Workbook "Scheduled_Tasks_2022.xlsx" Column "B" contains dates and if some date points to next week than values from columns "B", "D", "E" and "G" in the same row needs to be inserted into active Workbook table "Next_Week_Tasks.xlsm". I'm beginner to programming and VBA and I have no clue even how to begin with the code.
Please help!? Thanks in advance.

 

[DacEasy]

The solution below should work for your issue:

Sub forExtractByISOweek()
Application.DisplayAlerts = False

    MyDocsPath = Environ$("USERPROFILE") & "\\" & "Documents"
    Dim wbs As Workbook: Set wbs = Workbooks("Next_Week_Tasks.xlsm")
    Dim wbs1 As Workbook: Set wbs1 = Workbooks.Open(MyDocsPath & "\\Scheduled_Tasks_2022.xlsx")
    Dim mws As Worksheet: Set mws = wbs.Worksheets("Sheet1")
    
    wbs.Activate
    
    On Error Resume Next
    ActiveSheet.ListObjects("Table1").DataBodyRange.Delete 'Clear Table
    
    For Each Sheet In ActiveWorkbook.Worksheets 'Using a new sheet to perform the calculations
        If Sheet.Name = "calculateDate" Then
            Sheet.Delete
        End If
    Next Sheet
    
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "calculateDate"
    Dim dws As Worksheet: Set dws = wbs.Worksheets("calculateDate")
    
    Windows("Scheduled_Tasks_2022.xlsx").Activate
    Columns("B:G").Copy dws.Range("b1")  'Copy the data to CalculateDate
    
    wbs1.Close 'Close Scheduled_Tasks_2022.xlsx
    
    Columns("B:B").Copy Range("I1") 'Perform calculations on the date
    
    Dim lastrow As Long: Dim i As Long
    With ActiveSheet
        lastrow = .UsedRange.Rows.Count + .UsedRange.Row - 1
    End With
    
    Dim cell As Range, rng As Range, d As Date
    Set rng = Worksheets("calculateDate").Range("I2:I" & lastrow)

    For Each cell In rng 'change dd.mm.yyyy to mm/dd/yyyy
        With cell
            arr = Split(.Text, ".")
            .Value = DateSerial(arr(2), arr(1), arr(0))
            .NumberFormat = "m/dd/yyyy"
        End With
    Next cell

    For i = 2 To lastrow
       Range("J" & i).Value = Format(Range("i" & i).Value, "\Www") 'Change the date to an ISO number
       Range("k" & i).Value = Replace(Range("J" & i), "W", "")
    Next i
    
    mws.ListObjects(1).Name = "Table1"
    dws.ListObjects(1).Name = "Table2"
      
    Dim mtbl As ListObject: Set mtbl = mws.ListObjects("Table1")
    Dim dtbl As ListObject: Set dtbl = dws.ListObjects("Table2")
    
    dtbl.ListColumns.Add(1).Name = "ISO Digit" 'Add the ISO number to the table
    Columns("L:L").Copy Range("B1")
    
    Dim sCell As Range
    Dim srrg As Range
    Dim drrg As Range
    Dim r As Long

    For Each sCell In dtbl.ListColumns("Column1").DataBodyRange 'Current Week No. and Next Week No. are compared to the ISO number in the table
        r = r + 1
        If StrComp(CStr(sCell.Value), mws.Range("G2"), vbTextCompare) = 0 Or _
          StrComp(CStr(sCell.Value), mws.Range("H2"), vbTextCompare) = 0 Then
            Set srrg = dtbl.ListRows(r).Range
            Set drrg = mtbl.ListRows.Add.Range
            drrg.Cells(1).Value = srrg.Cells(2).Value 'Date
            drrg.Cells(2).Value = srrg.Cells(4).Value 'Wehicle
            drrg.Cells(3).Value = srrg.Cells(5).Value 'Task
            drrg.Cells(4).Value = srrg.Cells(7).Value 'Specialist
            drrg.Cells(5).Value = srrg.Cells(1).Value 'Week
        End If
    Next sCell
    
    Sheets("calculateDate").Delete
Application.DisplayAlerts = True
Range("A1").Select

End Sub

Sub clearTable()
    On Error Resume Next 'Added a Clear Table Button
    ActiveSheet.ListObjects("Table1").DataBodyRange.Delete
End Sub

 

[igor_majer]

The solution below should work for your issue:

Sub forExtractByISOweek()
Application.DisplayAlerts = False

    MyDocsPath = Environ$("USERPROFILE") & "\\" & "Documents"
    Dim wbs As Workbook: Set wbs = Workbooks("Next_Week_Tasks.xlsm")
    Dim wbs1 As Workbook: Set wbs1 = Workbooks.Open(MyDocsPath & "\\Scheduled_Tasks_2022.xlsx")
    Dim mws As Worksheet: Set mws = wbs.Worksheets("Sheet1")
   
    wbs.Activate
   
    On Error Resume Next
    ActiveSheet.ListObjects("Table1").DataBodyRange.Delete 'Clear Table
   
    For Each Sheet In ActiveWorkbook.Worksheets 'Using a new sheet to perform the calculations
        If Sheet.Name = "calculateDate" Then
            Sheet.Delete
        End If
    Next Sheet
   
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "calculateDate"
    Dim dws As Worksheet: Set dws = wbs.Worksheets("calculateDate")
   
    Windows("Scheduled_Tasks_2022.xlsx").Activate
    Columns("B:G").Copy dws.Range("b1")  'Copy the data to CalculateDate
   
    wbs1.Close 'Close Scheduled_Tasks_2022.xlsx
   
    Columns("B:B").Copy Range("I1") 'Perform calculations on the date
   
    Dim lastrow As Long: Dim i As Long
    With ActiveSheet
        lastrow = .UsedRange.Rows.Count + .UsedRange.Row - 1
    End With
   
    Dim cell As Range, rng As Range, d As Date
    Set rng = Worksheets("calculateDate").Range("I2:I" & lastrow)

    For Each cell In rng 'change dd.mm.yyyy to mm/dd/yyyy
        With cell
            arr = Split(.Text, ".")
            .Value = DateSerial(arr(2), arr(1), arr(0))
            .NumberFormat = "m/dd/yyyy"
        End With
    Next cell

    For i = 2 To lastrow
       Range("J" & i).Value = Format(Range("i" & i).Value, "\Www") 'Change the date to an ISO number
       Range("k" & i).Value = Replace(Range("J" & i), "W", "")
    Next i
   
    mws.ListObjects(1).Name = "Table1"
    dws.ListObjects(1).Name = "Table2"
     
    Dim mtbl As ListObject: Set mtbl = mws.ListObjects("Table1")
    Dim dtbl As ListObject: Set dtbl = dws.ListObjects("Table2")
   
    dtbl.ListColumns.Add(1).Name = "ISO Digit" 'Add the ISO number to the table
    Columns("L:L").Copy Range("B1")
   
    Dim sCell As Range
    Dim srrg As Range
    Dim drrg As Range
    Dim r As Long

    For Each sCell In dtbl.ListColumns("Column1").DataBodyRange 'Current Week No. and Next Week No. are compared to the ISO number in the table
        r = r + 1
        If StrComp(CStr(sCell.Value), mws.Range("G2"), vbTextCompare) = 0 Or _
          StrComp(CStr(sCell.Value), mws.Range("H2"), vbTextCompare) = 0 Then
            Set srrg = dtbl.ListRows(r).Range
            Set drrg = mtbl.ListRows.Add.Range
            drrg.Cells(1).Value = srrg.Cells(2).Value 'Date
            drrg.Cells(2).Value = srrg.Cells(4).Value 'Wehicle
            drrg.Cells(3).Value = srrg.Cells(5).Value 'Task
            drrg.Cells(4).Value = srrg.Cells(7).Value 'Specialist
            drrg.Cells(5).Value = srrg.Cells(1).Value 'Week
        End If
    Next sCell
   
    Sheets("calculateDate").Delete
Application.DisplayAlerts = True
Range("A1").Select

End Sub

Sub clearTable()
    On Error Resume Next 'Added a Clear Table Button
    ActiveSheet.ListObjects("Table1").DataBodyRange.Delete
End Sub

I works like a charm! DacEasy you're wizard! I really mean it! Although your code is very explicit and precise it will take some time to my full understanding. You got my great respect and gratitude. Thank you!

 

[DacEasy]

Glad It worked out, it was challenging. Step through with F8, to grasp it better.