Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 63
  • Last Modified:

Code Modification

Hi Experts,

Need A Help In Modifying Existing Macro In Attached WB..Please Help..
In Attached WB - Module - SingleToPost - Sub Cash ()....it Post Entries To Sheet Cash From sheet Single Entry - I need further more in this existing Sub ....it Post Exact Entry in Sheet LogFile & Then Remove Those Entries From Sheet Single Entry Without Affecting Formula in column  L to P.Existing Macro WillDone its jobNeed Further More StepsSteps without affecting Formulas
See Attached

Thanks
Portfolio-V06.xlsm
0
Naresh Patel
Asked:
Naresh Patel
  • 8
  • 6
1 Solution
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Try this...
Sub Cash()
Dim WS As Worksheet
Dim WSCash As Worksheet
Dim WSL As Worksheet
Dim MaxRow As Long, I As Long, MaxRowC As Long, lCount As Long

'---> Diable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'---> Set Variables
Set WS = Sheets("Single Entry")
Set WSCash = Sheets("Cash")
Set WSL = Sheets("LogFile")
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
MaxRowC = WSCash.Range("A" & WSCash.Rows.Count).End(xlUp).Row + 1

With WS.Rows(1)
   .AutoFilter field:=4, Criteria1:="Cash"
   If WS.Range("A1:A" & MaxRow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
      WS.Range("A2:H" & MaxRow).SpecialCells(xlCellTypeVisible).Copy WSL.Range("A2")
   End If
   .AutoFilter
End With
For I = 2 To MaxRow
    If LCase(WS.Cells(I, "D")) = "cash" Then
        If WS.Cells(I, "B") <> "" Then
            WSCash.Cells(MaxRowC, "A") = WS.Cells(I, "B")
        Else
            WSCash.Cells(MaxRowC, "A") = WS.Cells(I, "A")
        End If
        WSCash.Cells(MaxRowC, "B") = WS.Cells(I, "E")
        WSCash.Cells(MaxRowC, "C") = WS.Cells(I, "H")
        MaxRowC = MaxRowC + 1
        lCount = lCount + 1
    End If
Next I

WSCash.UsedRange.Sort Key1:=WSCash.Range("B1"), order1:=xlAscending, Header:=xlYes

MsgBox "A total of " & lCount & " Cash Items were copied to sheet Cash.", vbInformation, "Cash Transfer"

'---> Enable Events
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

Open in new window

0
 
Naresh PatelTraderAuthor Commented:
Code Seems working - it post entries to sheet Cash as well as to sheet LogFile but - last step is missing ...i.e. it wont remove cash entries from sheet Single Entry Sheet without affecting formulas in column L & onward.

Thanks
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Just add one line of code after line#36
WS.Rows(I).Delete

Open in new window

0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 
Naresh PatelTraderAuthor Commented:
i did but it transfer only 3 entries of cash instead of 4 i.e. Logfile sheet all 4 ...cash sheet 3 entries and removal 3 entries ...
Sub Cash()
Dim WS As Worksheet
Dim WSCash As Worksheet
Dim WSL As Worksheet
Dim MaxRow As Long, I As Long, MaxRowC As Long, lCount As Long

'---> Diable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'---> Set Variables
Set WS = Sheets("Single Entry")
Set WSCash = Sheets("Cash")
Set WSL = Sheets("LogFile")
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
MaxRowC = WSCash.Range("A" & WSCash.Rows.Count).End(xlUp).Row + 1

With WS.Rows(1)
   .AutoFilter field:=4, Criteria1:="Cash"
   If WS.Range("A1:A" & MaxRow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
      WS.Range("A2:H" & MaxRow).SpecialCells(xlCellTypeVisible).Copy WSL.Range("A2")
   End If
   .AutoFilter
End With
For I = 2 To MaxRow
    If LCase(WS.Cells(I, "D")) = "cash" Then
        If WS.Cells(I, "B") <> "" Then
            WSCash.Cells(MaxRowC, "A") = WS.Cells(I, "B")
        Else
            WSCash.Cells(MaxRowC, "A") = WS.Cells(I, "A")
        End If
        WSCash.Cells(MaxRowC, "B") = WS.Cells(I, "E")
        WSCash.Cells(MaxRowC, "C") = WS.Cells(I, "H")
        WS.Rows(I).Delete
        MaxRowC = MaxRowC + 1
        lCount = lCount + 1
    End If
Next I

WSCash.UsedRange.Sort Key1:=WSCash.Range("B1"), order1:=xlAscending, Header:=xlYes

MsgBox "A total of " & lCount & " Cash Items were copied to sheet Cash.", vbInformation, "Cash Transfer"

'---> Enable Events
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

Open in new window

Thanks
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
My bad. I forgot to tell you that you will have to loop in reverse order like this....

For I = MaxRow To 2 Step -1

Open in new window

0
 
Naresh PatelTraderAuthor Commented:
Neeraj will you please provide me full code?

Thanks
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay here it is......
Sub Cash()
Dim WS As Worksheet
Dim WSCash As Worksheet
Dim WSL As Worksheet
Dim MaxRow As Long, I As Long, MaxRowC As Long, lCount As Long

'---> Diable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'---> Set Variables
Set WS = Sheets("Single Entry")
Set WSCash = Sheets("Cash")
Set WSL = Sheets("LogFile")
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
MaxRowC = WSCash.Range("A" & WSCash.Rows.Count).End(xlUp).Row + 1

With WS.Rows(1)
   .AutoFilter field:=4, Criteria1:="Cash"
   If WS.Range("A1:A" & MaxRow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
      WS.Range("A2:H" & MaxRow).SpecialCells(xlCellTypeVisible).Copy WSL.Range("A2")
   End If
   .AutoFilter
End With
For I = MaxRow To 2 Step -1
    If LCase(WS.Cells(I, "D")) = "cash" Then
        If WS.Cells(I, "B") <> "" Then
            WSCash.Cells(MaxRowC, "A") = WS.Cells(I, "B")
        Else
            WSCash.Cells(MaxRowC, "A") = WS.Cells(I, "A")
        End If
        WSCash.Cells(MaxRowC, "B") = WS.Cells(I, "E")
        WSCash.Cells(MaxRowC, "C") = WS.Cells(I, "H")
        WS.Range("A" & I & ":H" & I).Delete shift:=xlUp
        MaxRowC = MaxRowC + 1
        lCount = lCount + 1
    End If
Next I

WSCash.UsedRange.Sort Key1:=WSCash.Range("B1"), order1:=xlAscending, Header:=xlYes

MsgBox "A total of " & lCount & " Cash Items were copied to sheet Cash.", vbInformation, "Cash Transfer"

'---> Enable Events
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

Open in new window

0
 
Naresh PatelTraderAuthor Commented:
May i ask FollowUp but this one is bit complex....?

Thanks
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
It depends If I am available to answer it.
Maybe you should open a new question along with a reference to this question so that other experts would also be able to help you.
0
 
Naresh PatelTraderAuthor Commented:
Neeraj Ji

Same Problem if there is only one cash entry in last row then it wont work.

See Attached
Portfolio-V06.xlsm
0
 
Naresh PatelTraderAuthor Commented:
New Question Posted.i dint link with this thread because it is different process then this question.

Thanks
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
That is because you are finding the last row in column A. Change the line to find the last row to this.....

MaxRow = WS.Range("D" & WS.Rows.Count).End(xlUp).Row
0
 
Naresh PatelTraderAuthor Commented:
Cash entry either remain on column A or B so above solution will taken care of both type of cases ?
0
 
Naresh PatelTraderAuthor Commented:
ok Done it is working ...posted new question regarding this question please look in to this.

Thanks
0

Featured Post

[Webinar On Demand] Database Backup and Recovery

Does your company store data on premises, off site, in the cloud, or a combination of these? If you answered “yes”, you need a data backup recovery plan that fits each and every platform. Watch now as as Percona teaches us how to build agile data backup recovery plan.

  • 8
  • 6
Tackle projects and never again get stuck behind a technical roadblock.
Join Now