VBA - Extracting Data to another sheet (Need help simplifying vba)

[tommiexboi]

Hello!

My macro below works. However, I believe it's not efficient.
Is there a way this can be written to make it more efficient?

I basically Frankenstein'd this from other macros, but surprising it works.

What this does is it extract months that are in columns to rows and insert the customer/item/number in each month in rows to the corresponding months.

Sub Extract()

ThisWorkbook.Worksheets("Forecast").Unprotect ("1234")

' Extract to Sheet

    Dim R As Range, c As Range, dest As Range, lR As Long, i As Long, F As Range, Rw As Range, Password As String
    Application.ScreenUpdating = False

Password = InputBox("Please enter Sales Group Password below", "Password", "")
    If Password <> "1234" Then
        MsgBox "Oops! You entered an incorrect password. Please try again!"
        
    ThisWorkbook.Worksheets("Forecast").Protect ("1234"), , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True
        
        Exit Sub
    Else
    End If

' Time Stamp
  
    Range("C8").Select
    ActiveCell.FormulaR1C1 = "=NOW()"
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

'customer/ item / product extraction


    Application.ScreenUpdating = False
Set F = Sheets("Forecast").Range("A14:C" & Sheets("Forecast").Cells(Rows.Count, "A").End(xlUp).Row)
Sheets("Extract").Range("A14:C" & Sheets("Extract").Cells(Rows.Count, "A").End(xlUp).Row + 1).ClearContents
For Each Rw In F.Rows
    Rw.Copy Sheets("extract").Range("A" & Sheets("extract").Cells(Rows.Count, "A").End(xlUp).Row + 1).Resize(15, 1)
Next Rw
Application.ScreenUpdating = True


' Data QTY, ASP, and Revenue Extraction

    
'QTY
    With Worksheets("Forecast")
        Set R = Range(.Range("J14"), .Range("J14").End(xlDown))
        For Each c In R
            Range(c, c.Range("O1")).Copy
            With Worksheets("Extract")
                Set dest = .Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
                dest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
            End With
        Next c
    End With
    
 'ASP    
    With Worksheets("Forecast")
            Set R = Range(.Range("AC14"), .Range("AC14").End(xlDown))
        For Each c In R
            Range(c, c.Range("O1")).Copy
            With Worksheets("Extract")
                Set dest = .Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
                dest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
            End With
        Next c
    End With
    
'Revenue 
       With Worksheets("Forecast")
            Set R = Range(.Range("AV14"), .Range("AV14").End(xlDown))
        For Each c In R
            Range(c, c.Range("O1")).Copy
            With Worksheets("Extract")
                Set dest = .Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)
                dest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
            End With
        Next c
    End With
    
 ' Month Extraction
    Sheets("Forecast").Activate
    Range("J13:X13").Select
    Selection.Copy
    Sheets("Extract").Activate
    Range("G2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    
 
    Lastrow = Range("A2").End(xlDown).Row
    Range("G2:G16").AutoFill Destination:=Range(Range("G2"), Range("G2:G" & Lastrow)), Type:=xlFillCopy
    
' Last Updated
    
    Sheets("Extract").Activate
    Range("H2").Select
    ActiveCell = "=Now()"
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    Lastrow = Range("A2").End(xlDown).Row
    Range("H2").AutoFill Destination:=Range(Range("H2"), Range("H2:H" & Lastrow)), Type:=xlFillCopy
    
 Cells.Validation.Delete
    
    
' Who Extracted?

    Sheets("Extract").Activate
    Range("I2").Select
    ActiveCell = "Sales Group"
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    Lastrow = Range("A2").End(xlDown).Row
    Range("I2").AutoFill Destination:=Range(Range("I2"), Range("I2:I" & Lastrow)), Type:=xlFillCopy
   
    ThisWorkbook.Worksheets("Forecast").Protect ("1234"), , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True
    
    Application.CutCopyMode = False
    MsgBox "Copying in Extract over"
    Application.ScreenUpdating = True
    
End Sub