Macro for copy paste in a collection

[Phung80219]

Please help me write a macro that will perform the following:

For every worksheets in workbook "book1.xls",

Copy the row where a cell in column k has any value that is not blank

Copy that row and paste it to workbook2's worksheet1.

Thank you in advance for helping!

[alansidman]

What have you attempted so far? Show us your in progress code so that it can be amended as necessary.

[Phung80219]

I am a newbie to VBA.. but here goes:

Sub WorksheetLoop()

         Dim WS_Count As Integer
         Dim I As Integer

       
         WS_Count = Workbooks("workbook1.xls").Worksheets.Count
         For I = 1 To WS_Count
			
			Range in Column K <> blank
			Select entire row
			Copy
			Paste to workbook2.worksheet1         
         Next I
End Sub

[alansidman]

Code Tags Added
Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

Posting code between tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found at http://www.excelforum.com/forum-rule...rum-rules.html



(Because you are new to the forum, I have added them for you today. Please take a few minutes to read all Forum Rules and comply in the future.)

[alansidman]

Give this a try:

Sub WorksheetLoop()
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim wk As Workbook
    'Next line assumes the second book is already open
    Set wk = Workbooks("Book2.xls") 'Change this to what you wish to call the second wkbook
    Dim sh As Worksheet
    Dim i As Long
    Dim lr As Long
    Dim lr2 As Long
    
    Application.ScreenUpdating = False
    For Each sh In wb
    lr = sh.Range("K" & Rows.Count).End(xlUp).Row
        For i = 1 To lr
        If sh.Range("K" & i) <> "" Then
        lr2 = wk.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
        sh.Range("K" & i).EntireRow.Copy wk.Sheets("Sheet1").Range("A" & lr2)
        End If
        Next i
    Next sh
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox ("Task Completed")
End Sub

Please note that this has not been tested on data as you did not supply a sample workbook.

[Phung80219]

I apologize for not ready the forum rules prior to posting

I will make sure to follow them going forward. Thank you for the kind notice!

I tried to run your script but received run-time error 438: Object doesn't support this property or method. No worries though because I had some help and the solution to my problem is below:

Sub rw_copy()

Dim wk As Worksheet
Dim rw1, rw2, ws_count As Integer
rw1 = 2
rw2 = 2

Workbooks("Book1").Activate
ws_count = ActiveWorkbook.Worksheets.Count

For i = 1 To ws_count
	Sheets(i).Activate
	Do While rw1 < 1000
	If Cells(rw1, 11) <> "" Then
		Rows(rw1).Copy
		Workbooks("Book2").Sheets("sheet1").Activate
		Rows(rw2).Select
		ActiveSheet.Paste
		Workbooks("Book1").Activate
		rw1 = rw1 + 1
		rw2 = rw2 + 1
		Else
		rw1 = rw1 + 1
	End If
	Loop
rw1 = 2
ws_count = ws_count + 1
Next i

End Sub

[Phung80219]

Actually, this is the code that works. The above code was missing a couple things.

Sub rw_copy()

Dim wk As Worksheet
Dim rw1, rw2, ws_count As Integer
Dim i As Long
rw1 = 2
rw2 = 2

Workbooks("book1.xlsx").Activate
ws_count = ActiveWorkbook.Worksheets.Count

For i = 1 To ws_count
    Sheets(i).Activate
    Do While rw1 < 1000
    If Cells(rw1, 11) <> "" Then
        Rows(rw1).Copy
        Workbooks("book2.xlsx").Sheets("sheet1").Activate
        Rows(rw2).Select
        ActiveSheet.Paste
        Workbooks("Book1.xlsx").Activate
        rw1 = rw1 + 1
        rw2 = rw2 + 1
        Else
        rw1 = rw1 + 1
    End If
    Loop
rw1 = 2
ws_count = ws_count + 1
Next i

End Sub