Copy sequentially through loop specific cells to another sheet

7absinth · Jul 13th 2022

Hello everybody.

I am struggling with the solution to copy out specific cells sequentially through the cells from 2 columns, but still no luck to complete it. Currently it do nothing.

The format that I want:

Code

Sub test()

Dim ws, ws2 As Worksheet, v As Variant, k As Long, i

Application.DisplayAlerts = False
Application.ScreenUpdating = False

On Error Resume Next

Sheets("NewSheet").Delete

k = 1
Sheets.Add.Name = "NewSheet"

Set ws = Worksheets("Details for we 200522")
Set ws2 = Worksheets("NewSheet")


ws.Activate
    For Each xcell In Intersect(Range("B:B"), ws.UsedRange)
         'Check if certain selected cell through loop starts with "33". If yes (>0) then copy this cell to ws2 in k row
         i = xcell.Value
         If InStr(i, Left(i, 2)) > 0 Then
            i.Copy ws2.Cells(k, 1)
            k = k + 1
            'to keep the format continue to check A:A column to proceed information copying
            For Each ycell In Intersect(Range("A:A"), ws.UsedRange)
                'Check if certain selected cell through loop starts with "UK". If yes (>0) then copy entire row to ws2 in k row
                j = ycell.Value
                    If InStr(j, Left(j, 2)) > 0 Then
                        i.Copy.EntireRow ws2.Cells(k, 1)
                        k = k + 1
                    End If
            Next ycell
          End If
    Next xcell
    
'Delete unnecessary columns to make the needed format
ws2.Range(Cells(1, 2), Cells(1, 7)).EntireColumn.Delete

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Display More

Where is the problem?

See below the file what I want to get.

**pike** · Jul 17th 2022

Hi 7absinth,

Consider something like ....

Code

Option Explicit
Sub testtwo()
    Dim ws, ws2 As Worksheet, k As Long, xcell As Variant
    Dim db()
    Dim strDate As String, strJob As String, strInvoice As String
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    On Error Resume Next
    Sheets("NewSheet").Delete
    k = 1
    Sheets.Add.Name = "NewSheet"
    Set ws = Worksheets("Details for we 200522")
    Set ws2 = Worksheets("NewSheet")
    With ws
        
        ReDim db(Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants)).Count, 6)
        
        For Each xcell In Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants))
            
          Select Case True
            Case xcell.Value Like "Date :"
                strDate = xcell.Offset(, 1).Value
            Case xcell.Value Like "Job :"
                strJob = xcell.Offset(, 1).Value
            Case xcell.Value Like "Invoice :"
                strInvoice = xcell.Offset(, 1).Value
            Case xcell.Value Like "UK*"
                db(k, 0) = strDate
                db(k, 1) = strJob
                db(k, 2) = strInvoice
                db(k, 3) = xcell.Value
                db(k, 4) = xcell.Offset(, 8).Value
                db(k, 5) = xcell.Offset(, 9).Value
            k = k + 1
            Case Else
          End Select
        
        Next xcell
       
       End With
        
        ws2.Range("A1").Resize(k, 6) = db

        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
    End Sub

Display More

7absinth · Jul 17th 2022

Nice try pike . But this is similar that I have made before without rules. But now there is the rules you didn't noticed.

The first rule as you see is :

1) 'Check if certain selected cell through loop in column B:B starts with "33". If yes (>0) then copy this cell to ws2 in k row

And the second one is (if the first rule is triggered)

2) 'Check if certain selected cell through loop in column A:A starts with "UK". If yes (>0) then copy entire to ws2 in k row

Both are commented in the code. You can check the format (M1:N9) that are marked in yellow to see the format how it should to look.

**pike** · Jul 20th 2022

try....

Code

Option Explicit
Sub testthree()
    Dim ws As Worksheet, ws2 As Worksheet, k As Long, xcell As Variant
    Dim db()
    Dim bln As Boolean
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    If Not Evaluate("IsError('NewSheet'!A1)") Then Sheets("NewSheet").Delete

    k = 1
    Sheets.Add.Name = "NewSheet"
    Set ws = Worksheets("Details for we 200522")
    Set ws2 = Worksheets("NewSheet")

    With ws
        ReDim db(1 To Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants)).Count, 1 To 2)

        For Each xcell In Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants))
            Select Case True
            Case xcell.Value Like "Invoice :"
                If xcell.Offset(, 1).Value Like "33*" Then
                    db(k, 1) = Split(xcell.Offset(, 1).Value, " ")(0)
                    k = k + 1
                    bln = True
                Else
                    bln = False
                End If
            Case xcell.Value Like "UK*" And bln
                db(k, 1) = xcell.Value
                db(k, 2) = xcell.Offset(, 8).Value
                k = k + 1
            Case Else
            End Select
        Next xcell
    End With

    ws2.Range("A1").Resize(k, 2) = db

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Display More

7absinth · Aug 4th 2022

Wow. Actually this works well. Very big thank you for your help delving this problem.

**pike** · Aug 4th 2022

glad it helped

Copy sequentially through loop specific cells to another sheet

7absinth Aug 4th 2022

Participate now!

Share

Similar Threads

VBA Copy rows to another sheet due to cell value from dropdown list

Copy specific cell data to summary tab based on tab name

Get Unique Value in Another Sheet in a Alphabetic Order

loop throught textboxes and copy to sheet

Need to loop through Sheet and Update another Sheet by way of Macro

Dynamically copy and paste sheet cells into a specific sheet

Tags