Add two more columns, modifying an existing VBA code help.

Hi all.

I want some help, to modify this VBA code. I want to copy additional columns Z and AA, the even numbered rows, starting with Z8.
Thank you in advance.

Sub test()
    Dim ws As Worksheet, i As Long, x As Range
    Application.ScreenUpdating = False
    With Sheets("CONTROL")
    .Select
        For Each ws In Worksheets(Array(2, 3, 4, 5, 6, 7))
            If ws.Name <> Me.Name Then
                With ws.Range("b9").CurrentRegion
                    For i = 1 To .Rows.Count Step 2
                        If x Is Nothing Then
                            Set x = .Rows(i).EntireRow.Range("b1,g1:h1")
                        Else
                            Set x = Union(x, .Rows(i).EntireRow.Range("b1,g1:h1"))
                        End If
                    Next
                End With
                If Not x Is Nothing Then
                    .Range("b" & Rows.Count).End(xlUp)(2).Select
                    x.Copy
                    Me.Paste link:=True
                End If
                Set x = Nothing
            End If
        Next
        .[b3].Select
    End With
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Your post does not comply with Rule 1 of our Forum RULES. Your post title should accurately and concisely describe your problem, not your anticipated solution.

Use terms appropriate to a Google search. Poor thread titles, like Please Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will be addressed according to the OP's experience in the forum: If you have less than 10 posts, expect (and respond to) a request to change your thread title. If you have 10 or more posts, expect your post to be locked, so you can start a new thread with an appropriate title.

To change a Title on your post, click EDIT then Go Advanced and change your title, if 2 days have passed ask a moderator to do it for you.

Hi zbor.

I do not know if my post title is better now. Accept any suggestion.
And what do you think about VBA code. You can give any help. No matter how small ..

With my poor knowledge, I changed (added another part). Miraculously works, but not correctly. It copies one extra row. After the last row that contains something in column B. Is empty. I do not need it.

Sub test()
    Dim ws As Worksheet, i As Long, x As Range
    Application.ScreenUpdating = False
    With Sheets("CONTROL")
    .Select
        For Each ws In Worksheets(Array("Sheet", "Sheet (2)", "Sheet (3)", "Sheet (4)", "Sheet (5)", "Sheet (6)"))
            If ws.Name <> Me.Name Then
                With ws.Range("b9").CurrentRegion
                    For i = 1 To .Rows.Count Step 2
                        If x Is Nothing Then
                            Set x = .Rows(i).EntireRow.Range("b1,g1:h1")
                        Else
                            Set x = Union(x, .Rows(i).EntireRow.Range("b1,g1:h1"))
                        End If
                    Next
                End With
                If Not x Is Nothing Then
                    .Range("b" & Rows.Count).End(xlUp)(2).Select
                    x.Copy
                    Me.Paste link:=True
                End If
                Set x = Nothing
            End If
        Next
        For Each ws In Worksheets(Array("Sheet", "Sheet (2)", "Sheet (3)", "Sheet (4)", "Sheet (5)", "Sheet (6)"))  '  Modified by me
            If ws.Name <> Me.Name Then  '  Added by me
                With ws.Range("b8").CurrentRegion  '  Added by me
                    For i = 2 To .Rows.Count Step 2  '  Added by me
                        If x Is Nothing Then '  Added by me
                            Set x = .Rows(i).EntireRow.Range("z1,aa1") '  Added by me
                        Else '  Added by me
                            Set x = Union(x, .Rows(i).EntireRow.Range("z1,aa1")) '  Added by me
                        End If '  Added by me
                    Next '  Added by me
                End With
                If Not x Is Nothing Then
                    .Range("e" & Rows.Count).End(xlUp)(2).Select
                    x.Copy
                    Me.Paste link:=True
                End If
                Set x = Nothing
            End If
        Next
        .[b3].Select
    End With
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Any help, no matter how small .. is greatly appreciated.

If necessary to pay, please tell me the price.

All help is free (volunteers, home, sparetime, etc.). You have to be patient, especially on the weekends. Post sample workbook for testing.
To Attach a Workbook:
1. Click on Go Advanced
2. In the frame Attach Files you will see the button Manage Attachments
3. Click the button.
4. A new window will open titled Manage Attachments - Excel Forum.
5. Click the Browse... button to locate your file for uploading.
6. This will open a new window File Upload.
7. Once you have located the file to upload click the Open button. This window will close.
8. You are now back in the Manage Attachments - Excel Forum window.
9. Click the Upload button and wait until the file has uploaded.
10. Close the window and then click Submit

Originally Posted by protonLeah

All help is free (volunteers, home, sparetime, etc.). You have to be patient, especially on the weekends. Post sample workbook for testing.

Ok. I am glad to hear that.
Here is the sample workbook for testing.

Here, try this.

This would check value in each sheet in B column. Then if something is in corresponding G column it will coppy all needed data.
That means for each name (For example B11) you must not have blank in G11.

rather that going to every second row.
Is this OK?

Originally Posted by zbor

Is this OK?

First of all, I must thank you for the help.
Yes. Works almost as I wanted. You missed just a small detail.
I want to link (cells) data from all sheets (B30=Sheet2!B7). The cells receives data online. If only I copy them, when they are updated, copied cells will not have the same values​​.
It's a little slow. I say this because I do not know it's normal to be, or I did something wrong?
Mine original workbook can have more than 30 sheets (20 on average).

Thank you

Now it will look all worksheets in workbook (no need to define them) except CONTROL.

Didn't understand part with links. You have url link on each value?

Sub copy_data()
    Dim ws As Worksheet, wsCTRL As Worksheet
    Dim LRws As Long, LRwsCTRL As Long
    Dim i As Integer
    
       
    Set wsCTRL = Sheets("CONTROL")
        wsCTRL.Rows("29:200").EntireRow.Delete
        
    On Error Resume Next
    For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> wsCTRL Then
        LRws = ws.Range("B65536").End(xlUp).Row
        LRwsCTRL = wsCTRL.Range("B65536").End(xlUp).Row
        wsCTRL.Range("B" & LRwsCTRL).Offset(1) = ws.Range("B1")
        
        For i = 2 To LRws
        If ws.Range("B" & i).Offset(0, 5) <> "" Then
            LRwsCTRL = wsCTRL.Range("B65536").End(xlUp).Row
            wsCTRL.Range("B" & LRwsCTRL).Offset(1).Value = ws.Range("B" & i).Value
        
        If ws.Range("B" & i).Hyperlinks.Count <> 0 Then
            wsCTRL.Hyperlinks.Add Anchor:=wsCTRL.Range("B" & LRwsCTRL).Offset(1), Address:=ws.Range("B" & i).Hyperlinks(1).Address, SubAddress:= _
    "", TextToDisplay:=ws.Range("B" & i).Value

            End If
            wsCTRL.Range("B" & LRwsCTRL).Offset(1, 1).Value = ws.Range("B" & i).Offset(0, 5).Value
            wsCTRL.Range("B" & LRwsCTRL).Offset(1, 2).Value = ws.Range("B" & i).Offset(0, 6).Value
            wsCTRL.Range("B" & LRwsCTRL).Offset(1, 3).Value = ws.Range("B" & i).Offset(1, 24).Value
            wsCTRL.Range("B" & LRwsCTRL).Offset(1, 4).Value = ws.Range("B" & i).Offset(1, 25).Value
        End If
        Next i
        End If
    Next ws
            
    

End Sub

Originally Posted by zbor

You have url link on each value?

Nope.
Not a hyperlink, just a simple link between copied cells.

Thanks again for your patience and your efforts.
Your first VBA works great.

My English is very poor. Everything is copied must be pasted as links.
Please see what the original VBA make, if you can.

Your code paste as valu.
Original paste as link. Paste link:=True

I attach a photo to see a comparison between VBA's. In this way you can easily understand.

OK, got it:

Sub copy_data()
    Dim ws As Worksheet, wsCTRL As Worksheet
    Dim LRws As Long, LRwsCTRL As Long
    Dim i As Integer
    
       
    Set wsCTRL = Sheets("CONTROL")
        wsCTRL.Rows("29:200").EntireRow.Delete ' Adopt your range if you have more rows  or remove this part if you want just to continue on existing data
        
    On Error Resume Next
    For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> wsCTRL.Name Then
        LRws = ws.Range("B65536").End(xlUp).Row
        LRwsCTRL = wsCTRL.Range("B65536").End(xlUp).Row
        wsCTRL.Range("B" & LRwsCTRL).Offset(1) = ws.Range("B1")
        wsCTRL.Range("B" & LRwsCTRL).Offset(1).Font.Color = RGB(Red:=255, Green:=0, Blue:=0)
        
        For i = 2 To LRws
        If ws.Range("B" & i).Offset(0, 5) <> "" Then
            LRwsCTRL = wsCTRL.Range("B65536").End(xlUp).Row
            wsCTRL.Range("B" & LRwsCTRL).Offset(1).Formula = "=" & ws.Range("B" & i).Address(External:=True)
            wsCTRL.Range("B" & LRwsCTRL).Offset(1, 1).Formula = "=" & ws.Range("B" & i).Offset(0, 5).Address(External:=True)
            wsCTRL.Range("B" & LRwsCTRL).Offset(1, 2).Formula = "=" & ws.Range("B" & i).Offset(0, 6).Address(External:=True)
            wsCTRL.Range("B" & LRwsCTRL).Offset(1, 3).Formula = "=" & ws.Range("B" & i).Offset(1, 24).Address(External:=True)
            wsCTRL.Range("B" & LRwsCTRL).Offset(1, 4).Formula = "=" & ws.Range("B" & i).Offset(1, 25).Address(External:=True)
        End If
        Next i
        End If
    Next ws
End Sub

Don't forget: IT will pull data from each sheet if there is something in G column. That's how I see esxample. Write if this is not a case.

Originally Posted by zbor

Write if this is not a case.

Hi zbor.

Again a big thank you for your effort.
The first code (who paste as values​​), works ok in my original sheet.
I do not know why but this time, the second code you provided does not work ok in my original sheet.
He copies all rows instead going to every second row.

I do not know if it helps much .. some detail.
Normally, the main (principal) data is in column B. If there is something automatically in column G (at least) is something. But this is not a problem because this part is easy to change, I think.
I have and some hidden sheets. For this I need to define where to look.
I have tried to change it, but so far .. only failure.

It didn't go to every second row.
Code check criteria:

If ws.Range("B" & i).Offset(0, 5) <> "" Then

So if ALL your data in B column has corresponding value in G column it will copy all of them.
If you don't have every 2nd row in G column blank then we need to change this criteria.

Originally Posted by zbor

If you don't have every 2nd row in G column blank ..

Then this may be the problem. G and H are the only columns that have values ​​in all rows.

How about header 4 and 5.
I mean, I can make solution with every 2nd row.
But if not, what would be other criteria for data you want to extract?

Originally Posted by zbor

How about header 4 and 5.

But if not

Excuse me but I did not understand exactly what you mean with header 4 and 5.
That would be a problem. Other criteria? I have not.
Maybe you can inspires in the original VBA and add only the other columns. Maybe it's easier? I do not know ..
Please try.

Here it is.
Puch zbor2 button and then push zbor button.
There will be one difference (I think ALADIN with value d on sheet 2).

That will show you difference in approaches.

Originally Posted by zbor

There will be one difference (I think ALADIN with value d on sheet 2).

Hi zbor

If you see the sheet, what I loaded it in post # 7 is different from the current sheet.
ALADIN with value d on sheet 2 does not exist, because this sheet does not exist.
I not warned you because I thought you made ​​these changes to test the VBA.
Another small detail: When data is copied to CONTROL sheet, cells change (just column B) their format from general to text. I think the original format of the sheets is copied, but here I need general format. If not, I see the formula in instead of the name, actually. But if it is difficult to change, there's no problem. I think I have to record a macro to change the cell format.
Anyway I did some tests and it seems to be working ok.
It's even more than I wanted.
That's it! A lot of work, but ... You solved it, buddy!
Many thanks, man ! Many thanks !

I think I know when cells change their format.
So. When I add the your last VBA in my original sheet and run the code for the first time everything is ok. But when I run the code a second time the cells in column B in sheet CONTROL, change their format.
It has something to do with:

Set wsCTRL = Sheets ("CONTROL")
         wsCTRL.Rows ("28:500"). EntireRow.DELETE

??

Okay.
I solved this "detail".
I added this.

Set wsCTRL = Sheets("CONTROL")
        wsCTRL.Rows("28:500").EntireRow.DELETE
        wsCTRL.Rows("28:500").NumberFormat = "General"

Many thanks again, man !
Thread solved.

Glad I helped.
I know there is no extra ALADIN row on that sheet. I just show you with that example what is difference between those two codes.

Just to mention: Criteria for searching values is that in B colum on each sheet must be "Heading 1".

Ok. Many thanks !