Could you check my code please.
Results 1 to 3 of 3

Thread: Could you check my code please.
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular
    Join Date
    Nov 2010
    Posts
    2,379
    Post Thanks / Like
    Mentioned
    9 Post(s)
    Tagged
    0 Thread(s)

    Default Could you check my code please.

    This is the whole code from my worksheet,



    When i click the Transfer button it should copy & paste like shown below.

    Copy G INCOME cell D31 & paste to G SUMMARY cell D9

    Copy G INCOME cell E31 & paste to G SUMMARY cell E9

    G INCOME D31 = £200.00 & pastes to G SUMMARY D9 £200.00 "correct"

    G INCOME E31 + 50 & pastes to G SUMMARY E9 200 "incorrect" should be 50

    Do you see why,as a test in D31 i put £135246 then looked at E9 where i then see 135246


    Code:
    Option ExplicitPublic PDFExists As Boolean
    Private Sub SUMMARYTRANSFER()
        Dim rFndCell As Range
        Dim strData As String
        Dim stFnd As String
        Dim fRow As Long
        Dim sh As Worksheet
        Dim ws As Worksheet
        Dim strDate As String
    
    
        Set ws = Sheets("G INCOME")
        Set sh = Sheets("G SUMMARY")
        stFnd = ws.Range("A3").Value
        strDate = ws.Range("A5").Value
        With sh
            Set rFndCell = .Range("C5:C17").Find(stFnd, LookIn:=xlValues)
            If Not rFndCell Is Nothing Then
                fRow = rFndCell.Row
                If CDate(strDate) > CDate("05/04/2019") Then
                    sh.Cells(fRow, 4).Resize(, 2).Value = ws.Range("D31,E31").Value
                Else:
                    sh.Cells(fRow - 12, 4).Resize(, 2).Value = ws.Range("D31,E31").Value
                End If
                MsgBox "Transfer To Summary Sheet Also Completed", vbInformation + vbOKOnly, "INCOME TRANSFER SHEET MESSAGE"
            Else
                MsgBox "DOES NOT EXIST", vbCritical + vbOKOnly, "SUMMARY TO TRANSFER SHEET FAILED MESSAGE"
                Range("A5").Select
            End If
            Range("A5:B30").ClearContents
            Range("A5").Select
            ActiveWorkbook.Save
        End With
    End Sub
    Private Sub INCOMETRANSFER()
    
    
        Dim strFileName As String
        
            strFileName = "C:\Users\Ian\Desktop\GRASS CUTTING\CURRENT GRASS SHEETS\INCOME 2019-2020\" & _
            Range("D3") & "_" & Format(Month(DateValue(Range("A3") & " 1, " & "2019")), "00") & " " & Range("A3") & ".pdf"
    
    
        If Dir(strFileName) <> vbNullString Then
            MsgBox "GRASS CUTTING INCOME SHEET " & Range("A3") & " " & Range("D3") & " WAS NOT SAVED AS IT ALREADY EXISTS", vbCritical + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
            PDFExists = True
            Exit Sub
        Else
            PDFExists = False
        End If
        
        With ActiveSheet
            .ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True
            MsgBox "GRASS CUTTING INCOME SHEET " & Range("A3") & " " & Range("D3") & " WAS SAVED SUCCESSFULLY", vbInformation + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
    
    
        End With
    
    
    End Sub
    Private Sub TransferButton_Click()
        
        Call INCOMETRANSFER
        
        If PDFExists Then
    '       Do nothing
        Else
            Call SUMMARYTRANSFER
        End If
        
    End Sub
    
    
    Private Sub Worksheet_Activate()
      Range("A3") = UCase(Format(Now, "mmmm"))
      Range("D3") = Year(Now)
      Range("A1:E3").HorizontalAlignment = xlCenter
      Range("A1:E3").VerticalAlignment = xlCenter
      Range("A1:E30, D31:E31, B35:C37, E35:E37 ").Borders.LineStyle = xlContinuous
      Range("A5").Select
      
    End Sub
    Private Sub Worksheet_Change(ByVal Target As Range)
    
    
    If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
    
    
    On Error Resume Next
    
    
    If Not Intersect(Target, Range("A1:E38")) Is Nothing Then
    Application.EnableEvents = False
    Target = UCase(Target)
    Application.EnableEvents = True
    
    
    End If
    On Error GoTo 0
    
    
    End Sub
    I have learning difficulties so please be patient if i'm slow on the uptake,Thanks Very Much...

  2. #2
    Board Regular
    Join Date
    Nov 2010
    Posts
    2,379
    Post Thanks / Like
    Mentioned
    9 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Could you check my code please.

    Hi,
    Still trying to get this right,

    I have changed the middle part to the below.


    Code:
         If CDate(strDate) > CDate("05/04/2019") Then
                    sh.Cells(fRow, 4).Resize(, 2).Value = ws.Range("D31").Value
                    sh.Cells(fRow, 5).Resize(, 3).Value = ws.Range("E31").Value
                Else:
                    sh.Cells(fRow - 12, 4).Resize(, 2).Value = ws.Range("D31").Value
                    sh.Cells(fRow - 12, 5).Resize(, 3).Value = ws.Range("E31").Value
                End If
    This then gets the correct value on the G SUMMARY PAGE BUT

    So i see this

    D9 £200.00

    E9 50

    F9 50

    G9 50

    Just the D9 & E9 would be nice
    I have learning difficulties so please be patient if i'm slow on the uptake,Thanks Very Much...

  3. #3
    Board Regular
    Join Date
    Nov 2010
    Posts
    2,379
    Post Thanks / Like
    Mentioned
    9 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Could you check my code please.

    Now all sorted.

    >Resize needed to be 1
    I have learning difficulties so please be patient if i'm slow on the uptake,Thanks Very Much...

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •