vba

[sna]

Dear All,
I need a simplified vba code to copy some values from Sheet"Date" to Sheet "Paster"
if Cell B1 is 1 so i need to copy data from Sheet "Date" of below data under of 1 in sheet "Date" to Sheet"Paster"
I attach a template
I have no luck

Noted: Dynamic array formula is allowed

Thx

[snasui]

The example of code is below.

Code: Select all

'Othe code
    ' Loop through each row in the Date sheet and copy rows based on the value in column A
    For i = 2 To lastRowDate
'        If wsDate.Cells(i, 1).Value = cellValue Then
            wsDate.Rows(i).Copy Destination:=wsPaster.Rows(destRow)
            destRow = destRow + 1
'        End If
    Next i
'Other code

[sna]

I mean to copy only when cell value is 1 equals to column a in sheet "Date" 1 SoSambath 13-09-2024
A Input Office OutSide Authorize Amount
- Transaction 30 - 74 -
- BookingLoan/Reschedule 1 - 1 -
- BookingMCMM/ReEV 1 - - -
- CheckCIF(Credit/FSR) 9 - - -
- PDArrear 7 - 4 -
- RunPayroll 7 - - -
- TaxCar/Payment 1 - - -
- AM(Form50-147) - - 1 -
- ChangeInfomationCIF/ACC - - 1 -
- VMS - - 13 -
B CrossService - - - -
- ReferralPrudential - - - -
- ReferralLoan - - - -
- OtherService - - - -
C Total: 56 - 94 -
D Subtotal: 150 - - -

[snasui]

Please try this code.

Code: Select all

Sub Test0()
    Dim fOne As Range, fStt As Range
    Dim lstC As Range, srRngs As Range
    
    If Not IsNumeric(Worksheets("Paster").Range("B1")) Then
        MsgBox "The value in A1 is not a valid number.", vbExclamation
        Exit Sub
    End If
    
    With Worksheets("Date")
        Set lstC = .Range("b" & .Rows.Count).End(xlUp)
        Set fOne = .Range("a:a").Find(what:=1, LookIn:=xlValues, lookat:=xlPart)
        Set fStt = .Range(fOne, lstC).Find(what:="Subtotal:", LookIn:=xlValues, lookat:=xlPart)
        Set srRngs = .Range(fOne, fStt).Resize(, 6)
    End With
    With Worksheets("Paster")
        .Range("b1").CurrentRegion.Offset(1, 0).ClearContents
        .Range("b2").Resize(srRngs.Rows.Count, srRngs.Columns.Count).Value = srRngs.Value
    End With
End Sub

[sna]

Thanks so much

[sna]

Hi Dear,
I need to copy all data meet criteria in cell B1 in Sheet Paster .

I attach a template

thx

[snasui]

The example code is below.

Code: Select all

Sub Test1()
    Dim ws As Worksheet
    Dim firstAddress As String
    Dim cell As Range, sv As String
    Dim cpRngs As Range

    Set ws = ThisWorkbook.Sheets("Date")
    Set wt = ThisWorkbook.Sheets("Paster")
    
    With wt
        sv = wt.Range("b1").Value
        .UsedRange.Offset(1, 0).ClearContents
    End With
    
    Set cell = ws.Columns("B").Find(What:=sv, LookIn:=xlValues, LookAt:=xlWhole)

    If Not cell Is Nothing Then
        firstAddress = cell.Address
        Do
            With ws
                Set cpRngs = .Range(cell, cell.End(xlDown))
            End With
            With wt
                cpRngs.Resize(, 6).Copy .Range("b" & .Rows.Count).End(xlUp).Offset(1, 0)
            End With
            Set cell = ws.Columns("B").FindNext(cell)
        Loop While Not cell Is Nothing And cell.Address <> firstAddress
    End If
End Sub

[sna]

Thanks ,really helpful