Repeat 1 cell as many times as there are entries in another column

[mt03530]

Hello!

My ultimate goal is to pull 3 types of information from n number of worksheets into a summary page. I was successful with copying and pasting unique values (see below), however, I am having issues copying one cell from each worksheet and having it repeat multiple times.

I have multiple worksheets that look something like this:
[TABLE="width: 200"]
<tbody>[TR]
[TD]Amanda[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ID[/TD]
[TD]Color[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Gold[/TD]
[/TR]
</tbody>[/TABLE]

My code for copying ID and Color is:

Private Sub CommandButton1_Click()
    Dim wks As Worksheet


     
    For Each wks In ThisWorkbook.Worksheets
        If Not wks.Name = "Summary" Then
            wks.Range("A7:A" & wks.Cells(Rows.Count, "A").End(xlUp).Row).Copy _
            Destination:=Worksheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1)
               wks.Range("D7:D" & wks.Cells(Rows.Count, "D").End(xlUp).Row).Copy _
            Destination:=Worksheets("Summary").Cells(Rows.Count, "B").End(xlUp).Offset(1)


        End If
    Next
    
    
End Sub

Without having to count the number of entries myself, how do I now copy "Amanda" for each entry for Amanda (in this case 3 times)? Thanks!

 

[Fluff]

How about

Private Sub CommandButton1_Click()
   Dim Wks As Worksheet
   Dim Rng As Range
   
   With Sheets("Summary")
      For Each Wks In ThisWorkbook.Worksheets
         If Not Wks.Name = "Summary" Then
            Set Rng = Wks.Range("A7:A" & Wks.Cells(Rows.Count, "A").End(xlUp).Row)
            With .Range("A" & Rows.Count).End(xlUp)
               Rng.Copy .Offset(1)
               Rng.Offset(, 3).Copy .Offset(1, 1)
               .Offset(1, 2).Resize(Rng.Count).Value = Wks.Name
               Set Rng = Nothing
            End With
         End If
      Next Wks
   End With
   
End Sub

This will put the sheet name in col C

 

[mt03530]

How about

Private Sub CommandButton1_Click()
   Dim Wks As Worksheet
   Dim Rng As Range
   
   With Sheets("Summary")
      For Each Wks In ThisWorkbook.Worksheets
         If Not Wks.Name = "Summary" Then
            Set Rng = Wks.Range("A7:A" & Wks.Cells(Rows.Count, "A").End(xlUp).Row)
            With .Range("A" & Rows.Count).End(xlUp)
               Rng.Copy .Offset(1)
               Rng.Offset(, 3).Copy .Offset(1, 1)
               .Offset(1, 2).Resize(Rng.Count).Value = Wks.Name
               Set Rng = Nothing
            End With
         End If
      Next Wks
   End With
   
End Sub

This will put the sheet name in col C

I'm not sure that I understand what is being done here.

The cell I want to copy is A4 in every worksheet, not the sheet name. Maybe I didn't make myself clear in my question, sorry!

 

[Fluff]

In that case make this change

.Offset(1, 2).Resize(Rng.Count).Value = [COLOR=#ff0000]Wks.Range("A4")[/COLOR]

 

[mt03530]

In that case make this change

.Offset(1, 2).Resize(Rng.Count).Value = [COLOR=#ff0000]Wks.Range("A4")[/COLOR]

I tried to combine that with my existing code and received an error.

Private Sub CommandButton1_Click()
    Dim wks As Worksheet


     
    For Each wks In ThisWorkbook.Worksheets
        If Not wks.Name = "Summary" Then
            wks.Range("A7:A" & wks.Cells(Rows.Count, "A").End(xlUp).Row).Copy _
            Destination:=Worksheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1)
               wks.Range("D7:D" & wks.Cells(Rows.Count, "D").End(xlUp).Row).Copy _
            Destination:=Worksheets("Summary").Cells(Rows.Count, "B").End(xlUp).Offset(1)
[COLOR=#0000cd]Set Rng = wks.Range("A7:A" & wks.Cells(Rows.Count, "A").End(xlUp).Row)[/COLOR]
[COLOR=#0000cd]            With .Range("A" & Rows.Count).End(xlUp)[/COLOR]
[COLOR=#0000cd]               Rng.Copy .Offset(1)[/COLOR]
[COLOR=#0000cd]               Rng.Offset(, 3).Copy .Offset(1, 1)[/COLOR]
[COLOR=#0000cd]               .Offset(1, 2).Resize(Rng.Count).Value = wks.Range("A4")[/COLOR]
[COLOR=#0000cd]               Set Rng = Nothing[/COLOR]
[COLOR=#0000cd]           End With[/COLOR]
[COLOR=#0000cd]         End If[/COLOR]
[COLOR=#0000cd]      Next wks[/COLOR]
[COLOR=#0000cd]   End With[/COLOR]

    
    Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).ClearFormats
    Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).ClearFormats
    
End Sub

Thank you for hanging in here with me!

 

[Fluff]

The code I supplied replaces all your code, with the exception of the last 2 line, which you didn't originally have.

 

[mt03530]

The code I supplied replaces all your code, with the exception of the last 2 line, which you didn't originally have.

Oh I see! So instead of designating columns, offset was used, correct? That is so much cleaner.

Thank you so much!!! This saves me 1.5 hours of work each month!


Do you mind if I ask another question about this same code?
Sometimes my coworkers forget to add all the information I need. How can I run this code, but if a cell is blank to copy the blank and move on?

 

[Fluff]

I'm afraid I don't understand.
Could you re-explain?

 

[mt03530]

I'm afraid I don't understand.
Could you re-explain?

When I run this code, it results in the data being offset.

Worksheet
[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Color[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Purple[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]Red[/TD]
[/TR]
</tbody>[/TABLE]

Result
[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Color[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]Purple[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Red[/TD]
[/TR]
</tbody>[/TABLE]

What I want
[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Color[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Purple[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]Red[/TD]
[/TR]
</tbody>[/TABLE]


I want the code to be able to copy an empty cell. Does that make more sense?

Thanks!

 

[Fluff]

How about

Private Sub CommandButton1_Click()
   Dim Wks As Worksheet
   Dim Rng As Range
   
   With Sheets("Summary")
      For Each Wks In ThisWorkbook.Worksheets
         If Not Wks.Name = "Summary" Then
            Set Rng = Wks.Range("A7:A" & Wks.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row)
            With .Range("A" & .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row)
               Rng.Copy .Offset(1)
               Rng.Offset(, 3).Copy .Offset(1, 1)
               .Offset(1, 2).Resize(Rng.Count).Value = Wks.Range("A4")
               Set Rng = Nothing
            End With
         End If
      Next Wks
   End With
   
End Sub

This assumes that you have something in the summary sheet when you run the code