Xplaywrightt
New Member
- Joined
- Aug 16, 2023
- Messages
- 4
- Office Version
- 365
- Platform
- MacOS
I need help with an excel VBA code for a sch. proj. pls. The code moves contents from a "2C" sheet when cell contains the text "Less Than 30" to a final sheet name "<30day." The current code moves the entire column from "2C" to column A in "Less Than 30", I want it to move it to column B in "Less Than 30" because I want to put something in column A.
The current code clears what I put in column A of "Less Than 30" when run.
Im not a coder and this code is from a YouTuber (Excel 10)
Below is the attached code.
Private Sub Worksheet_Change ByVal Target As
Range)
Dim Z As Long
Dim xVal As String
On Error Resume Next
If Intersect(Target, Range("AK:AK")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Z = 1 To Target.Count
If Target (Z). Value > 0 Then
Call CopyRowBasedOnCellValue
End If
Next
Application.EnableEvents = True
End Sub
Sub CopyLessThan30Days2C()
Dim xRg As Range
Dim Cell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets ("2C").UsedRange.Rows.Count
B=
Worksheets ("<30days").UsedRange.Rows.Count
If B = 1 Then
If
Application.WorksheetFunction.CountA(Worksheets
("<30days").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets ("2C").Range("AK1:AK" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(×Rg(C).Value) = "Less Than 30" Then
XRg(C).EntireRow.Copy
Destination:=Worksheets ("<30days").Range ("A" & B
+ 1)
B=B+ 1
End If
Worksheets"<30days").UsedRange.RemoveDuplic ates Columns: =1, Header:=xIYes
Worksheets ("<30days").UsedRange.SpecialCells(xl
CellTypeBlanks).Delete xIShiftUp
Next
Application.ScreenUpdating = True
End Sub
The current code clears what I put in column A of "Less Than 30" when run.
Im not a coder and this code is from a YouTuber (Excel 10)
Below is the attached code.
Private Sub Worksheet_Change ByVal Target As
Range)
Dim Z As Long
Dim xVal As String
On Error Resume Next
If Intersect(Target, Range("AK:AK")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Z = 1 To Target.Count
If Target (Z). Value > 0 Then
Call CopyRowBasedOnCellValue
End If
Next
Application.EnableEvents = True
End Sub
Sub CopyLessThan30Days2C()
Dim xRg As Range
Dim Cell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets ("2C").UsedRange.Rows.Count
B=
Worksheets ("<30days").UsedRange.Rows.Count
If B = 1 Then
If
Application.WorksheetFunction.CountA(Worksheets
("<30days").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets ("2C").Range("AK1:AK" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(×Rg(C).Value) = "Less Than 30" Then
XRg(C).EntireRow.Copy
Destination:=Worksheets ("<30days").Range ("A" & B
+ 1)
B=B+ 1
End If
Worksheets"<30days").UsedRange.RemoveDuplic ates Columns: =1, Header:=xIYes
Worksheets ("<30days").UsedRange.SpecialCells(xl
CellTypeBlanks).Delete xIShiftUp
Next
Application.ScreenUpdating = True
End Sub