VBA code to copy to a specific sheet

[dpaton05]

I am trying to make some way to transfer specific entries to a monthly sheet, that is not depending on the date. I want to select the row then choose a month from a combo, txtDirectMonth and type a year into txtDirectYear then press a button. I then want the row to transfer to the relevant monthly sheet. There are sheets, July 2018 to June 2019. What code could I use?

 

[DanteAmor]

If your combobox or textbox are ActiveX controls then put the following code in your button.

Private Sub CommandButton1_Click()
    Dim exist As Boolean
    Dim wName As String
    Dim sh As Worksheet
    Dim wRow As Double, uRow As Double
    
    Application.ScreenUpdating = False
    
    'Validations
    If txtDirectMonth.Value = "" Then
        MsgBox "Enter Month"
        txtDirectMonth.Select
        Exit Sub
    End If
    
    If txtDirectYear.Value = "" Then
        MsgBox "Enter Year"
        txtDirectYear.Select
        Exit Sub
    End If
    
    exist = False
    wName = LCase(txtDirectMonth.Value) & " " & LCase(txtDirectYear.Value)
    For Each sh In Sheets
        If LCase(sh.Name) = wName Then
            exist = True
            Exit For
        End If
    Next
    If exist = False Then
        MsgBox "The sheet : " & wName & " does not exist", vbCritical
    Else
        wRow = ActiveCell.Row
        uRow = Sheets(wName).Range("A" & Rows.Count).End(xlUp).Row + 1
        ActiveSheet.Rows(wRow).Copy
        Sheets(wName).Rows(uRow).PasteSpecial xlValue
        ActiveSheet.Rows(wRow).Delete
    End If
    
    Application.ScreenUpdating = False
        
    MsgBox "Transferred row"
End Sub

Try and tell me.

 

[dpaton05]

Try and tell me.

Thank you, that is brilliant! I forgot to tell you one thing. Not every column in the row is needed as some columns are used for calculation purposes, etc. On the monthly sheet, I need these columns from the home sheet- A-J, O, AD-AF. A-J will go to columns A-J on the monthly sheet, O will go to column K and AD-AF from the home sheet will go to columns N-P on the monthly sheet. I also need formulas in columns L and M on each monthly sheet.

L = K * 0.1
M = L + K


Thanks for helping me

 

[DanteAmor]

goes the updated code

Private Sub CommandButton1_Click()
    Dim exist As Boolean
    Dim wName As String
    Dim sh As Worksheet
    Dim wRow As Double, uRow As Double
    
    Application.ScreenUpdating = False
    
    'Validations
    If txtDirectMonth.Value = "" Then
        MsgBox "Enter Month"
        txtDirectMonth.Select
        Exit Sub
    End If
    
    If txtDirectYear.Value = "" Then
        MsgBox "Enter Year"
        txtDirectYear.Select
        Exit Sub
    End If
    
    exist = False
    wName = LCase(txtDirectMonth.Value) & " " & LCase(txtDirectYear.Value)
    For Each sh In Sheets
        If LCase(sh.Name) = wName Then
            exist = True
            Exit For
        End If
    Next
    If exist = False Then
        MsgBox "The sheet : " & wName & " does not exist", vbCritical
    Else
        wRow = ActiveCell.Row
        uRow = Sheets(wName).Range("A" & Rows.Count).End(xlUp).Row + 1
        Range(Cells(wRow, "A"), Cells(wRow, "J")).Copy
        Sheets(wName).Range("A" & uRow).PasteSpecial xlValue
        
        Range(Cells(wRow, "O"), Cells(wRow, "O")).Copy
        Sheets(wName).Range("K" & uRow).PasteSpecial xlValue
        
        Range(Cells(wRow, "AD"), Cells(wRow, "AF")).Copy
        Sheets(wName).Range("N" & uRow).PasteSpecial xlValue
        
        Sheets(wName).Range("L" & uRow).Formula = "=K" & uRow & " * 0.1"
        Sheets(wName).Range("M" & uRow).Formula = "=L" & uRow & " + K" & uRow
        'ActiveSheet.Rows(wRow).Copy
        'Sheets(wName).Rows(uRow).PasteSpecial xlValue
        ActiveSheet.Rows(wRow).Delete
    End If
    
    Application.ScreenUpdating = False
        
    MsgBox "Transferred row"
End Sub

 

[dpaton05]

Thank you, that is awesome!!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[dpaton05]

You're welcome

 

[dpaton05]

goes the updated code

Private Sub CommandButton1_Click()
    Dim exist As Boolean
    Dim wName As String
    Dim sh As Worksheet
    Dim wRow As Double, uRow As Double
    
    Application.ScreenUpdating = False
    
    'Validations
    If txtDirectMonth.Value = "" Then
        MsgBox "Enter Month"
        txtDirectMonth.Select
        Exit Sub
    End If
    
    If txtDirectYear.Value = "" Then
        MsgBox "Enter Year"
        txtDirectYear.Select
        Exit Sub
    End If
    
    exist = False
    wName = LCase(txtDirectMonth.Value) & " " & LCase(txtDirectYear.Value)
    For Each sh In Sheets
        If LCase(sh.Name) = wName Then
            exist = True
            Exit For
        End If
    Next
    If exist = False Then
        MsgBox "The sheet : " & wName & " does not exist", vbCritical
    Else
        wRow = ActiveCell.Row
        uRow = Sheets(wName).Range("A" & Rows.Count).End(xlUp).Row + 1
        Range(Cells(wRow, "A"), Cells(wRow, "J")).Copy
        Sheets(wName).Range("A" & uRow).PasteSpecial xlValue
        
        Range(Cells(wRow, "O"), Cells(wRow, "O")).Copy
        Sheets(wName).Range("K" & uRow).PasteSpecial xlValue
        
        Range(Cells(wRow, "AD"), Cells(wRow, "AF")).Copy
        Sheets(wName).Range("N" & uRow).PasteSpecial xlValue
        
        Sheets(wName).Range("L" & uRow).Formula = "=K" & uRow & " * 0.1"
        Sheets(wName).Range("M" & uRow).Formula = "=L" & uRow & " + K" & uRow
        'ActiveSheet.Rows(wRow).Copy
        'Sheets(wName).Rows(uRow).PasteSpecial xlValue
        ActiveSheet.Rows(wRow).Delete
    End If
    
    Application.ScreenUpdating = False
        
    MsgBox "Transferred row"
End Sub

Why are two lines of code commented out near the bottom?

 

[DanteAmor]

are from the previous version

 

[dpaton05]

Do I need them?