VBA Macro: Copy and Paste Specific Row Range based on the Specific Value in a Cell.

(How to) Upload a Workbook directly to the Forum
(please do not post pictures or links to worksheets)

• Click Advanced next to Quick Post button at the bottom right of the editor box.
• Scroll down until you see "Manage Attachments",
• Click the "Choose" button at the upper left (upload from your computer).
• Select your file, click "open", click "upload"
• Once the upload is completed the file name will appear below the input boxes in this window.
• Close the Attachment Manager window.
• Click "Submit Reply"

Note: Please do not attach password protected workbooks/worksheets
Ensure to disable any Workbook Open/Autorun macros before attaching!

Sorry for double post. I've shrunk down the info to the most basic - no code or formulas, and am now able to upload the file


In the file you will see the main sheet - Sheet 1, which contains information (diaries) of individuals. Their availability is marked in this sheet for the entire week.

Now, if you go to sheet Sunday, you will see a slightly different list of individuals, same goes for sheet Monday, and that is because I've manually copied and pasted individuals who are available on that day and their availability times from the main sheet and pasted the info on to the relevant day sheet.

What I want VBA to do is to identify who's "Active" on Sheet1 and transfer (extract) specific information (as shown in sheets Sunday and Monday) and their availability hours for that day into another sheet, or in other words automate the manual process that I've described above.


Thank you all for having a look at this.

This one macro will do it on any sheet that is active when you run the macro. I've changed the name of your main sheet from Sheet1 to Availability. I also tweaked your headers slightly for appearance.

Option Explicit

Sub DailyAvailability()
Dim wsMAIN As Worksheet, wsME As Worksheet, meFIND As Range, LR As Long

Set wsMAIN = Sheets("Availability")             'the sheet with the hours
Set wsME = ActiveSheet                          'the currrent sheet to update

On Error Resume Next
With wsMAIN
    LR = .Range("A" & .Rows.Count).End(xlUp).Row        'find the last row of availability date
    Set meFIND = .Rows(2).Find(wsME.Name, LookIn:=xlValues, LookAt:=xlWhole)    'find the current day
    If Not meFIND Is Nothing Then                       'if sheetname/day is found, proceed
        wsME.UsedRange.Clear                            'clear prior info
        .AutoFilterMode = False                         'remove prior filters
        .Rows(3).AutoFilter meFIND.Column, "Active"     'filter daily column for "active" only
        .Range("A2:F" & LR).Copy wsME.Range("A2")       'copy name info, then copy hours
        .Range(.Cells(2, meFIND.Column - 2), .Cells(LR, meFIND.Column - 1)).Copy wsME.Range("G2")
        .AutoFilterMode = False
        Application.CutCopyMode = False
        wsME.Columns.AutoFit
    End If
End With

End Sub

Couldn't say. The suggestion given matched the data available in the sample workbook.

I cant seem to open that file.

OK, added some new features.

1) The DAILYAVAILABILITY Macro now looks at cell C1 on each sheet from which it is called to see what "week #" you have selected to display.
2) C1 has a drop down listing all the Week #s currently contained on the Availability sheet
3) The ThisWorkbook module now has a "SheetActivate" macro that updates the drop down list in realtime anytime you activate a sheet. So the drop down will always be current for the sheet you are reviewing.
4) If the current value of C1 is NOT a week that is found on the Availability sheet any longer, the sheet automatically run the update macro to display the first week it does find. After that, you can select any other week from the C1 drop down and UPDATE it again.

ThisWorkbook code:

Option Explicit

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim buf As String, cell As Range

If Sh.Name <> "Availability" Then
    With Sheets("Availability")
        For Each cell In .Rows(1).SpecialCells(xlConstants)
            If cell.Value <> "" Then
                If buf = "" Then
                    buf = cell.Value
                Else
                    buf = buf & "," & cell.Value
                End If
            End If
        Next cell
    End With
    If buf <> "" Then
        With Sh.Range("C1").Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=buf
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
        Range("C1").Activate
        If InStr(buf, Range("C1").Value) = 0 Then
            If InStr(buf, ",") = 0 Then
                Range("C1") = buf
            Else
                Range("C1") = Left(buf, InStr(buf, ",") - 1)
            End If
            Call Module1.DailyAvailability
        End If
    End If
End If

End Sub

Updated DailyAvailibilty code in module1:

Option Explicit

Sub DailyAvailability()
Dim wsMAIN As Worksheet, wsME As Worksheet, meFIND As Range, LR As Long
Dim wkFIND As Range

Set wsMAIN = Sheets("Availability")             'the sheet with the hours
Set wsME = ActiveSheet                          'the currrent sheet to update

On Error Resume Next
With wsMAIN
    Set wkFIND = wsMAIN.Rows(1).Find(wsME.Range("C1").Text, LookIn:=xlValues, LookAt:=xlWhole).MergeArea.Cells
    LR = .Range("A" & .Rows.Count).End(xlUp).Row        'find the last row of availability date
    Set meFIND = Intersect(.Range(wkFIND.Address).EntireColumn, .Rows(2)).Find(wsME.Name, _
                   LookIn:=xlValues, LookAt:=xlWhole)   'find the current day
    If Not meFIND Is Nothing Then                       'if sheetname/day is found, proceed
        wsME.UsedRange.Offset(1).Clear                  'clear prior info
        .AutoFilterMode = False                         'remove prior filters
        .Rows(3).AutoFilter meFIND.Column, "Active"     'filter daily column for "active" only
        .Range("A2:F" & LR).Copy wsME.Range("A2")       'copy name info, then copy hours
        .Range(.Cells(2, meFIND.Column - 2), .Cells(LR, meFIND.Column - 1)).Copy wsME.Range("G2")
        .AutoFilterMode = False
        Application.CutCopyMode = False
        wsME.Columns.AutoFit
    End If
End With

End Sub

EEK. You want a macro to put what could be randomized information from the Availability sheet into a Daily sheet, then you are going to manually add data to the Daily sheets? You see how out-of-sync that will get with even the smallest "update"?

I understood all that implicitly. The dangers of what you're doing is what I'm forcing a conversation about.

In terms of process, the current new design will only change the sheet, wiping out your notes, if you click the UPDATE button.
Were I forced into this design/process, I'd never click the UPDATE button again on a sheet I'd already starting the final planning as you're describing. Once that had begun, someone calling in sick, so to speak, I would change their availability right on the daily sheet. I'd never use the Update at all once I'd started manual notations.