Excel-Not Responding State

[GirishDhruva]

Hi everyone,
Here i am trying with this code for copying the values which are present in column 'B' based on column 'H' ,i have tried with the below code but it takes me lot of time , if i have huge data in my sheet, it goes to Excel-Not Responding State
Is their any other possible way to perform this

Here My main goal is to copy the values of column B that are present in between the values of column 'H' and paste that in another sheet

Slno	Column B	...	Column H
1	111		1212
2	222
3	333
4	444
5	555		12345
6	666
7	777		12333
8	888
9	999		12312
10	1000

<tbody>
</tbody>

Sub looping()
Dim lastrow, i As Long
lastrow = Cells(Rows.Count, "H").End(xlUp).Row
    For i = 2 To lastrow
        If Cells(i, 8).Value = "" Then
            Cells(i, 2).Copy
            Worksheets("Sheet2").Select
            Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
            Worksheets("Sheet2").Paste
            Worksheets("Sheet1").Select
        End If
    Next i
End Sub

Thanks in advance

 

[lrobbo314]

All of the selecting and copying and pasting is not good practice. The code below loads everything into an array and uses that for the logic. A lot faster, and should take care of the 'not responding' garbage.

Sub looping2()
Application.ScreenUpdating = False
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2")
Dim AR() As Variant: AR = ws1.Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")


For i = LBound(AR) To UBound(AR)
    If AR(i, 8) = "" Then AL.Add AR(i, 2)
Next i


With ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(AL.Count)
    .Value = Application.Transpose(AL.toArray)
End With


Application.ScreenUpdating = True
End Sub

 

[GirishDhruva]

All of the selecting and copying and pasting is not good practice. The code below loads everything into an array and uses that for the logic. A lot faster, and should take care of the 'not responding' garbage.

Sub looping2()
Application.ScreenUpdating = False
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2")
Dim AR() As Variant: AR = ws1.Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")


For i = LBound(AR) To UBound(AR)
    If AR(i, 8) = "" Then AL.Add AR(i, 2)
Next i


[COLOR=#ff0000]With ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(AL.Count)[/COLOR]
    .Value = Application.Transpose(AL.toArray)
End With


Application.ScreenUpdating = True
End Sub

Thanks for your effort, but i am getting an error in highlighted row as "Application defined or object defined error"
could you help me what changes i have to make

Thank you in advance

 

[GirishDhruva]

Can anyone help me how can i solve this

 

[lrobbo314]

Made a couple of small changes.

Sub looping2()
Application.ScreenUpdating = False
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2")
Dim AR() As Variant: AR = ws1.Range("A2:H" & ws1.Range("A" & Rows.Count).End(xlUp).Row).Value
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")


For i = LBound(AR) To UBound(AR)
    If AR(i, 8) = "" Then AL.Add AR(i, 2)
Next i


With ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(AL.Count)
    .Value = Application.Transpose(AL.toArray)
End With


Application.ScreenUpdating = True
End Sub

 

[GirishDhruva]

That's working , Thank you and one more doubt, if i need to copy multiple cells and paste in different columns in Sheet2

Like Below Table , i need to copy Column'B' values from Sheet1 and paste in Column'A' in Sheet2 and copy Column'M' from Sheet1 and paste to Column'Z' in Sheet2

slno	name	column B	Column H	Column M
1	asedf	111	12345	0987
2	qwer	222		9876543
3	bsfdbfd	333		8765
4	qwerf	444	5433	34567
5	sadfdsf	555		8765423
6	gedfgg	666	2345	9876345
7	zvxcbvcjtr	777		763267
8	eryewa	888	1345	234586
9	rtesd	999		23458754

<tbody>
</tbody>

Thanks in advance

 

[lrobbo314]

───────────────────░█▓▓▓█░▇▆▅▄▃▂
──────────────────░█▓▓▓▓▓█░▇▆▅▄▃▂
─────────────────░█▓▓▓▓▓█░▇▆▅▄▃▂
──────────░░░───░█▓▓▓▓▓▓█░▇▆▅▄▃▂ ...
─────────░███░──░█▓▓▓▓▓█░▇▆▅▄▃▂
───────░██░░░██░█▓▓▓▓▓█░▇▆▅▄▃▂
──────░█░░█░░░░██▓▓▓▓▓█░▇▆▅▄▃▂
────░██░░█░░░░░░█▓▓▓▓█░▇▆▅▄▃▂
───░█░░░█░░░░░░░██▓▓▓█░▇▆▅▄▃▂
──░█░░░░█░░░░░░░░█▓▓▓█░▇▆▅▄▃▂
──░█░░░░░█░░░░░░░░█▓▓▓█░▇▆▅▄▃▂
──░█░░█░░░█░░░░░░░░█▓▓█░▇▆▅▄▃▂
─░█░░░█░░░░██░░░░░░█▓▓█░▇▆▅▄▃▂
─░█░░░░█░░░░░██░░░█▓▓▓█░▇▆▅▄▃▂
─░█░█░░░█░░░░░░███▓▓▓▓█░▇▆▅▄▃▂
░█░░░█░░░██░░░░░█▓▓▓▓▓█░▇▆▅▄▃▂
░█░░░░█░░░░█████▓▓▓▓▓█░▇▆▅▄▃▂
░█░░░░░█░░░░░░░█▓▓▓▓▓█░▇▆▅▄▃▂
░█░█░░░░██░░░░█▓▓▓▓▓█░▇▆▅▄▃▂
─░█░█░░░░░████▓▓▓▓██░▇▆▅▄▃▂
─░█░░█░░░░░░░█▓▓██▓█░▇▆▅▄▃▂
──░█░░██░░░██▓▓█▓▓▓█░▇▆▅▄▃▂
───░██░░███▓▓██▓█▓▓█░▇▆▅▄▃▂
────░██▓▓▓███▓▓▓█▓▓▓█░▇▆▅▄▃▂
──────░█▓▓▓▓▓▓▓▓█▓▓▓█░▇▆▅▄▃▂
──────░█▓▓▓▓▓▓▓▓▓▓▓▓▓█░▇▆▅▄▃▂───────────────────░█▓▓▓█░▇▆▅▄▃▂
──────────────────░█▓▓▓▓▓█░▇▆▅▄▃▂
─────────────────░█▓▓▓▓▓█░▇▆▅▄▃▂
──────────░░░───░█▓▓▓▓▓▓█░▇▆▅▄▃▂ ...
─────────░███░──░█▓▓▓▓▓█░▇▆▅▄▃▂
───────░██░░░██░█▓▓▓▓▓█░▇▆▅▄▃▂
──────░█░░█░░░░██▓▓▓▓▓█░▇▆▅▄▃▂
────░██░░█░░░░░░█▓▓▓▓█░▇▆▅▄▃▂
───░█░░░█░░░░░░░██▓▓▓█░▇▆▅▄▃▂
──░█░░░░█░░░░░░░░█▓▓▓█░▇▆▅▄▃▂
──░█░░░░░█░░░░░░░░█▓▓▓█░▇▆▅▄▃▂
──░█░░█░░░█░░░░░░░░█▓▓█░▇▆▅▄▃▂
─░█░░░█░░░░██░░░░░░█▓▓█░▇▆▅▄▃▂
─░█░░░░█░░░░░██░░░█▓▓▓█░▇▆▅▄▃▂
─░█░█░░░█░░░░░░███▓▓▓▓█░▇▆▅▄▃▂
░█░░░█░░░██░░░░░█▓▓▓▓▓█░▇▆▅▄▃▂
░█░░░░█░░░░█████▓▓▓▓▓█░▇▆▅▄▃▂
░█░░░░░█░░░░░░░█▓▓▓▓▓█░▇▆▅▄▃▂
░█░█░░░░██░░░░█▓▓▓▓▓█░▇▆▅▄▃▂
─░█░█░░░░░████▓▓▓▓██░▇▆▅▄▃▂
─░█░░█░░░░░░░█▓▓██▓█░▇▆▅▄▃▂
──░█░░██░░░██▓▓█▓▓▓█░▇▆▅▄▃▂
───░██░░███▓▓██▓█▓▓█░▇▆▅▄▃▂
────░██▓▓▓███▓▓▓█▓▓▓█░▇▆▅▄▃▂
──────░█▓▓▓▓▓▓▓▓█▓▓▓█░▇▆▅▄▃▂
──────░█▓▓▓▓▓▓▓▓▓▓▓▓▓█░▇▆▅▄▃▂

 

[GirishDhruva]

That's working , Thank you and one more doubt, if i need to copy multiple cells and paste in different columns in Sheet2

Like Below Table , i need to copy Column'B' values from Sheet1 and paste in Column'A' in Sheet2 and copy Column'M' from Sheet1 and paste to Column'Z' in Sheet2

slno	name	column B	Column H	Column M
1	asedf	111	12345	0987
2	qwer	222		9876543
3	bsfdbfd	333		8765
4	qwerf	444	5433	34567
5	sadfdsf	555		8765423
6	gedfgg	666	2345	9876345
7	zvxcbvcjtr	777		763267
8	eryewa	888	1345	234586
9	rtesd	999		23458754

<tbody>
</tbody>

Thanks in advance

Can this be done????

 

[lrobbo314]

How about this?

Sub looping2()
Application.ScreenUpdating = False
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2")
Dim AR() As Variant: AR = ws1.Range("A2:M" & ws1.Range("A" & Rows.Count).End(xlUp).Row).Value
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim AL2 As Object: Set AL2 = CreateObject("System.Collections.ArrayList")




For i = LBound(AR) To UBound(AR)
    If AR(i, 8) = "" Then
        AL.Add AR(i, 2)
        AL2.Add AR(i, 13)
    End If
Next i




ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(AL.Count).Value = Application.Transpose(AL.toArray)
ws2.Range("Z" & Rows.Count).End(xlUp).Offset(1).Resize(AL2.Count).Value = Application.Transpose(AL2.toArray)


Application.ScreenUpdating = True
End Sub

 

[GirishDhruva]

Cheers, Thank you It worked perfectly ...