Excel VBA / Loop to copy unknown number of columns underneath each other, and string to each cell, AND adjecent cells!

[Young Grasshopper]

Hi,

I have this worksheet where which is devided into sections (TestCampaign1 etc). In the example underneath there are just two sections, but in the finished worksheet there will be 100 sections. Everytime the worksheet is used, there will be diffrent informasjon in each section and numbers of rows will also vary. The numbers of sections used will vary from time to time.
There will also be common that only one column in a section is being used.

I need a code that do the following in a efficiant and smart way:
(let's use the example in the picture as a example)

1. Copy filled cells from C4 and down (.End(xlDown)) and paste it to say M1 f.ex.
2. Then copy filled cells from D4 and downwards and paste it to M1.End(xlDown).Offset(1) with "" on each side of the value, so like "KeywordExample"
3. Same with e4. Paste to with [ and ] on each side of the value, so like ([KeywordExample])
4. Then the section name and group name needs to be added to the adjecent cells for each entry under m1. So TestCampaign1 in the K column, and TestGroup1 in the L column.

5. Then move on to the next "section", G4 and repete the prosess, pasting to ("M1").End(xlDown).Offset(1), same with H (with "value") and I (with [value]), and TestCampaign2 and TestGroup2 added to the adjecent cells to these.

6. then repeting the prosess until the loop hits a section where none of the columns are being used.

So the result will be one long column in m, with every entry stacked ontop of eachother, with the correct section name and group name in the adjecent cells. There could potentially be 150 000 entries, so the faster the code the better

I tried a code that went something like this, but this was just messy and didn't really work..

Private Sub Test()

Dim MyRange As Range
Dim MyRange2 As Range
Dim MyRange3 As Range
Dim Cell As Range

If ThisWorkbook.Worksheets("KeywordsTest").Range("D5").value <> "" Then

Dim rSource As Range, rDest As Range, rDest2 As Range, rDest3 As Range, r As Range
Dim tbl As Range, rowNum As Integer
Const colNum = 3



Dim Campaign As String
Dim Adset As String

Set rDest = ThisWorkbook.Worksheets("KeywordsTest").Range("M1")
Set rDest2 = ThisWorkbook.Worksheets("KeywordsTest").Range("P1")
Set rDest3 = ThisWorkbook.Worksheets("KeywordsTest").Range("S1")
Set rSource = ThisWorkbook.Worksheets("KeywordsTest").Range("C4")
Set r = rSource


While r <> ""

    'Bred
    Set tbl = Range(r, r.End(xlDown))
  
    rDest.value = tbl.value
   
    Set MyRange = Range(rDest, rDest.End(xlDown))
    For Each Cell In MyRange
    If Cell.value <> "" And Cell.Offset(, -2).value = "" Then
    Cell.Offset(, -2).value = r.Offset(-3, 1).value
    Cell.Offset(, -1).value = r.Offset(-2, 1).value
    End If
    Next Cell
   
    Set rDest = rDest.End(xlDown).Offset(1, 0)
   
    'Setning
    Set r = r.Offset(, 1)
    Set tbl = Range(r, r.End(xlDown))
    tbl.Copy
    rDest2.PasteSpecial (xlPasteValues)
   
    Set MyRange2 = Range(rDest2, rDest2.End(xlDown))
    For Each Cell In MyRange2
    If Cell.value <> "" And Cell.Offset(, -2).value = "" Then
    Cell.Offset(, -2).value = r.Offset(-3, 1).value
    Cell.Offset(, -1).value = r.Offset(-2, 1).value
    End If
    Next Cell
   
    Set rDest2 = rDest2.End(xlDown).Offset(1, 0)
   
    'Eksakt
    Set r = r.Offset(, 1)
    Set tbl = Range(r, r.End(xlDown))
    tbl.Copy
    rDest3.PasteSpecial (xlPasteValues)
   
    Set MyRange3 = Range(rDest3, rDest3.End(xlDown))
    For Each Cell In MyRange3
    If Cell.value <> "" And Cell.Offset(, -2).value = "" Then
    Cell.Offset(, -2).value = r.Offset(-3, 1).value
    Cell.Offset(, -1).value = r.Offset(-2, 1).value
   
    End If
    Next Cell
   
    rDest3 = rDest3.End(xlDown).Offset(1, 0)
   
     r = r(0, 2)
    
   
   
For Each Cell In MyRange2
If Cell.value <> "" Then
Cell.value = "[" & Cell.value & "]"
    End If
    Next Cell

    Wend

End If

    End If
    Next Cell


End Sub

I'm really stuck here, so would appreciate any help:D

 

[offthelip]

I hope I have understood the requirements correctly but if not it shoudl be easy to change. The technique I have used is to load all of the data inot a variant array and then run through in three loops in memory and write the results out to another varaint array. The outside loop (k) selects between column CDE and GHI in turn , the second loop (i) goes down the rows and the third loop (j) goes across the 3 columns This should super fast even for 150 thousand entries.

Sub bigcopy()
fc = Array("", Chr(34), "[")
lc = Array("", Chr(34), "]")
  Dim outarr()
  lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   ReDim outarr(1 To lr * 6, 1 To 3)
   inarr = Range(Cells(4, 3), Cells(lr, 9)) ' pick up all the data
   indi = 1
   hd1 = Range("D1")
   hd2 = Range("D2")
 
   For k = 0 To 7 Step 4
   For i = 1 To UBound(inarr)
    If inarr(i, 1 + k) <> "" Then
      For j = 1 To 3
        outarr(indi, 1) = hd1
        outarr(indi, 2) = hd2
        outarr(indi, 3) = fc(j - 1) & inarr(i, j + k) & lc(j - 1)
        indi = indi + 1
     Next j
 
   End If
   Next i
   hd1 = Range("H1")
   hd2 = Range("H2")
 
   Next k
  Range(Cells(1, 11), Cells(indi - 1, 13)) = outarr
 
End Sub

 

[Young Grasshopper]

This is like magic to me, but it works brilliant!
Had to tweak it a littlebit to make it do exactly what i wanted, but your code was 99% correct.

This is what i ended up with:

Sub bigcopy()

Dim fc, lc, lr, inarr, indi, indi2, hd1, hd2, k, i, j

fc = Array("", Chr(34), "[")
lc = Array("", Chr(34), "]")
  Dim outarr()
  lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   ReDim outarr(1 To lr * 9, 1 To 3)
   inarr = Range(Cells(4, 3), Cells(lr, 17)) ' pick up all the data
   indi = 1
   indi2 = 0
   hd1 = Range("D1")
   hd2 = Range("D2")
 
   For k = 0 To 15 Step 4
   For i = 1 To UBound(inarr)
    If inarr(i, 1 + k) <> "" Or inarr(i, 2 + k) <> "" Or inarr(i, 3 + k) <> "" Then
      For j = 1 To 3
      If inarr(i, j + k) <> "" Then
        outarr(indi, 1) = hd1
        outarr(indi, 2) = hd2
        outarr(indi, 3) = fc(j - 1) & inarr(i, j + k) & lc(j - 1)
        indi = indi + 1
        Else
        End If
     Next j
 
   End If
   Next i
   hd1 = Range("H1").Offset(0, indi2 * 4)
   hd2 = Range("H2").Offset(0, indi2 * 4)
   indi2 = indi2 + 1
   
   Next k
  Range(Cells(1, 19), Cells(indi - 1, 21)) = outarr
 
End Sub

Thank you for your help, offthelip!
Enjoy the rest of your day

 

[kevin9999]

I note you have a perfectly good solution from @offthelip to your original question, although I note you mentioned there could be:

in the finished worksheet there will be 100 sections.

I'd already started looking at this before you had your accepted answer, but I thought I may as well finish it off (I hate half finishing code ). I also interpreted your final layout differently, and I may be totally wrong anyway? The following is flexible insofar as it will pick up on however many "sections" there are, and the column lengths can vary as well. Tested it with 100 sections with a total of 150K values at around 1.5 seconds on my creaky old machine. Provided for interest sake only.

Option Explicit
Sub bigcopy_flexible()
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<~~ change to suit
    Dim z As Long, LCol As Long
    z = WorksheetFunction.CountA(ActiveSheet.UsedRange.Offset(3))
    LCol = ws.Cells.Find("*", , xlFormulas, , 2, 2).Column + 2
    
    Dim FirstCell As Range
    Set FirstCell = Range("C4")
    Dim Campaign As String, Group As String
    Dim col As Long, i As Long, j As Long, ArrOut, temp
    col = FirstCell.Column
    
    ReDim ArrOut(1 To z, 1 To 3)
    i = 1
    Do Until i > z
    
        Campaign = ws.Cells(1, col).Value
        Group = ws.Cells(2, col).Value
        
        temp = ws.Range(ws.Cells(4, col), ws.Cells(ws.Cells(Rows.Count, col).End(xlUp).Row, col))
        For j = 1 To UBound(temp)
            ArrOut(i, 1) = Campaign
            ArrOut(i, 2) = Group
            ArrOut(i, 3) = temp(j, 1)
            i = i + 1
        Next j
        
        col = col + 1
        temp = ws.Range(ws.Cells(4, col), ws.Cells(ws.Cells(Rows.Count, col).End(xlUp).Row, col))
        For j = 1 To UBound(temp)
            ArrOut(i, 1) = Campaign
            ArrOut(i, 2) = Group
            ArrOut(i, 3) = "'""" & temp(j, 1) & """"
            i = i + 1
        Next j
        
        col = col + 1
        temp = ws.Range(ws.Cells(4, col), ws.Cells(ws.Cells(Rows.Count, col).End(xlUp).Row, col))
        For j = 1 To UBound(temp)
            ArrOut(i, 1) = Campaign
            ArrOut(i, 2) = Group
            ArrOut(i, 3) = "[" & temp(j, 1) & "]"
            i = i + 1
        Next j
        
        col = ws.Cells(4, col).End(xlToRight).Column
    
    Loop
    ws.Cells(1, LCol).Resize(UBound(ArrOut, 1), 3).Value = ArrOut
    ws.Cells(1, LCol).Resize(, 3).EntireColumn.AutoFit
End Sub

 

[kevin9999]

I just noticed you're getting the Campaign and Group text from the middle column of each section, therefore my suggestion in post #4 needs to be adjusted to this:

Option Explicit
Sub bigcopy_flexible_V2()
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<~~ change to suit
    Dim z As Long, LCol As Long
    z = WorksheetFunction.CountA(ActiveSheet.UsedRange.Offset(3))
    LCol = ws.Cells.Find("*", , xlFormulas, , 2, 2).Column + 2
    
    Dim FirstCell As Range
    Set FirstCell = Range("C4")
    Dim Campaign As String, Group As String
    Dim col As Long, i As Long, j As Long, ArrOut, temp
    col = FirstCell.Column
    
    ReDim ArrOut(1 To z, 1 To 3)
    i = 1
    Do Until i > z
    
        Campaign = ws.Cells(1, col + 1).Value
        Group = ws.Cells(2, col + 1).Value
        
        temp = ws.Range(ws.Cells(4, col), ws.Cells(ws.Cells(Rows.Count, col).End(xlUp).Row, col))
        For j = 1 To UBound(temp)
            ArrOut(i, 1) = Campaign
            ArrOut(i, 2) = Group
            ArrOut(i, 3) = temp(j, 1)
            i = i + 1
        Next j
        
        col = col + 1
        temp = ws.Range(ws.Cells(4, col), ws.Cells(ws.Cells(Rows.Count, col).End(xlUp).Row, col))
        For j = 1 To UBound(temp)
            ArrOut(i, 1) = Campaign
            ArrOut(i, 2) = Group
            ArrOut(i, 3) = "'""" & temp(j, 1) & """"
            i = i + 1
        Next j
        
        col = col + 1
        temp = ws.Range(ws.Cells(4, col), ws.Cells(ws.Cells(Rows.Count, col).End(xlUp).Row, col))
        For j = 1 To UBound(temp)
            ArrOut(i, 1) = Campaign
            ArrOut(i, 2) = Group
            ArrOut(i, 3) = "[" & temp(j, 1) & "]"
            i = i + 1
        Next j
        
        col = ws.Cells(4, col).End(xlToRight).Column
    
    Loop
    ws.Cells(1, LCol).Resize(UBound(ArrOut, 1), 3).Value = ArrOut
    ws.Cells(1, LCol).Resize(, 3).EntireColumn.AutoFit
End Sub