a different kind of Copy and Paste using VBA

[PancarHx1]

I was not able to find a similar thread and would like to ask for your help in achieving this task using VBA code:

I create a permutation table (a table that could be up to 20 columns max but rows could be much more up to a thousand or more - usually no numbers just text) and finalize it and place it on sheet 1 of a workbook and by way of a macro or VBA code I would like to copy and paste it as seen in sheet 2 of the same workbook: row 1 on sheet 1 go into cell 'A1' of sheet 2, row 2 of sheet 1 go into cell 'A2' of sheet 2, row 3 on sheet 1 go into cell A3 of sheet 2 and so on until the end of the table (Nth row of sheet 1 into cell AN of sheet 2) in the format seen in fig 2 (red to red, blue to blue just to show e.g. first 5 columns horizontally with hyphens in between and columns 6 to 13 under Data: with hyphens before them vertically). The other text in cell A1, A2, A3 etc. (in black) most of the time stays the same.

Thank you.

fig. 1 sheet 1


fig. 2 sheet 2

 

[PancarHx1]

Sorry, I forgot to add the file

 

[vletm]

@PancarHx1
Something like this ... after press [ A > B ]
(I left Your sample result there too.)

 

[PancarHx1]

@vletm
Thank you, thank you and thank you. The formatting didn't work at first but worked perfectly after I put some Chr(10) at the end of some lines (maybe because of version differences).

I was able to change it a bit to satisfy variable nature of Sheet1. The slogans could be variable as well and slogan 3 and 4 actually have to go to corresponding B1, B2, B3 etc. Couldn't manage that!

 

[vletm]

@PancarHx1
1) Your sample has two different layouts.
I used the 1st 'format layout'.
What are differences?
2) Slogans...
Do every row have 'own unique two slogans'? (= 640 slogans)
If YES then it's possible to as You 'changed' sheet
If NO then there is more user friendly possible.

 

[PancarHx1]

@vletm
yes vletm I wanted to make all 4 slogans variable as well; the first two will go in A cells (as in cell A1, A2 in Sheet 2 just to show) and the last 2 will go into B cells like I tried to show in Sheet 2 but I couldn't manage to do it. Here is an updated but incomplete version Thank you again.

 

[vletm]

@PancarHx1
four set of Slogans
with layout of Your samples

 

[PancarHx1]

@vletm
thank you vletm, but I probably couldn't explain it well. If you see this sheet I'm attaching and the vba code in the workbook that you had started that I modified to provide the variable nature of the fields and the explanations with the green comments it might be more clear. Please also see sheet1 data; I put separators 1, 2 and 3 to differentiate between the header, the first two slogans and the last two slogans etc. I did not change them in the sample (sheet1) but the slogans will also be variable so I would have to do a loop for them as well which I started at the bottom in the code but couldn't figure it out the rest. Sheet 2 shows first two rows as a sample of what it has to be for 321 columns in this case. Also I have to add these Chr(10)s for it to format properly, could that be because I'm running Excel 2007.

Sub A_to_B()

    'turn off screen updating so the macro doesn't show the steps and also runs faster
    'Application.ScreenUpdating = False

    a_tab = "Sheet1"
    b_tab = "Sheet2"
   
    Sheets(b_tab).Range("A:A").ClearContents
   
    'calculate the number of rows in the table
    y_max = Sheets(a_tab).Cells(Rows.Count, 1).End(xlUp).Row
   
    'calculate the number of columns in the table
    x_max = Sheets(a_tab).Cells(2, Columns.Count).End(xlToLeft).Column
   
    'calculate the number of header columns - the columns before 1
    cnum1 = Application.Match(1, Sheets(a_tab).Range("A1:BA1"), 0)
   
    'calculate the number of mid slogans - the columns between 1 and 2
    'these are the comments between the header and the variable data listed
    cnum2 = Application.Match(2, Sheet1.Range("A1:BA1"), 0)
   
    'calculate the number of end slogans - the columns after 3
    'these comments go to cell B1 and down
    cnum3 = Application.Match(3, Sheet1.Range("A1:BA1"), 0)
   
   
    Dim R_data()
    ReDim R_data(x_max)
   
    slogan1 = "This is to ildahu ehhueyh ekjh eu ewerh her wkeher wehrjkwe" & Chr(13) & _
                    "kjkrjwekro oi rj wlerj erjwelrjk rkl:"
    slogan2 = "Then lkjdfj  iuwiur werkjwr weho wer jrlkkrjwlkjklwj wlrjwr wejrwelrwejkr" & Chr(13) & _
                    "jdfjsdfh wkhjrf hwjkfhwjkr hwrjk."
   
   
    'to write all cells from (in this case) A1 to A(nth)
    For y = 1 To y_max
       
        'to assign R_data() all values (strings) in the columns
        For x = 1 To x_max
            R_data(x) = Sheets(a_tab).Cells(y, x)
        Next x
       
        'Header - to assign b_text the Header values with hyphen
        b_atxt = R_data(1)
        For x = 2 To (cnum1 - 1)
            b_atxt = b_atxt & " - " & R_data(x)
        Next x
        b_atxt = b_atxt & Chr(13) & Chr(10) & Chr(10)
       
        'to add the slogan 1 and data: to b_text
        b_atxt = b_atxt & slogan1 & Chr(13) & Chr(10) & Chr(10)
        b_atxt = b_atxt & "Data:" & Chr(13) & Chr(10)
       
        'to assign the variable data to b_text with hyphens and linebreaks
        For x = (cnum2 + 1) To (cnum3 - 1)
            b_atxt = b_atxt & "- " & R_data(x) & Chr(13) & Chr(10)
        Next x
        b_atxt = b_atxt & Chr(13) & Chr(10)
       
        'to add the slogan 2 to b_text
        b_atxt = b_atxt & slogan2 & Chr(13)
       
       
        'For x = (cnum3 + 1) To x_max
            'b_btxt = R_data(x)
       
        'to write all of b_text to cell A1, A2 etc on the loop
        Sheets(b_tab).Cells(y, 1) = b_atxt
       
        'to write all of b_btxt to cell B1, B2 etc on the loop
        'Sheets(b_tab).Cells(y, 2) = b_btxt
       
    Next y

    Sheets(b_tab).Select
    'Application.ScreenUpdating = True
   
   
End Sub

 

[vletm]

@PancarHx1
#5 Reply
1) You couldn't name differences, so layout is as same as You sample.
#6 Reply
2) You wrote FOUR slogans, not 640 slogans! I made this for FOUR slogans.
Did You check my previous version?

Of course, You can modify code as You want and add comments, no matter.
But sometimes, even minor modification can make ... big changes; need tests.
If no clear vision of Your needs, it's challenge to change.

 

[PancarHx1]

@vletm
Fair enough! I was able to complete what I was trying to do thanks to your initial code. It was easier than I originally thought. Thanks again.

Sub A_to_B()

    'turn off screen updating so the macro doesn't show the steps and also runs faster
    Application.ScreenUpdating = False

    a_tab = "Sheet1"
    b_tab = "Sheet2"
   
    Sheets(b_tab).Range("A:B").ClearContents
   
    'calculate the number of rows in the table
    y_max = Sheets(a_tab).Cells(Rows.Count, 1).End(xlUp).Row
   
    'calculate the number of columns in the table
    x_max = Sheets(a_tab).Cells(2, Columns.Count).End(xlToLeft).Column
   
    'calculate the number of header columns - the columns before 1
    cnum1 = Application.Match(1, Sheets(a_tab).Range("A1:BA1"), 0)
   
   
   
    Dim R_data()
    ReDim R_data(x_max)
   
   
   
    'to write all cells from (in this case) A1 to A(nth)
    For y = 1 To y_max
       
        'to assign R_data() all values (strings) in the columns
        For x = 1 To x_max
            R_data(x) = Sheets(a_tab).Cells(y, x)
        Next x
       
        'Header - to assign b_text the Header values with hyphen
        b_atxt = R_data(1)
        For x = 2 To (cnum1 - 5)
            b_atxt = b_atxt & " - " & R_data(x)
        Next x
        b_atxt = b_atxt & Chr(13) & Chr(10) & Chr(10)
       
        'to add the slogan 1 and data: to b_text
        b_atxt = b_atxt & R_data(cnum1 - 4) & Chr(13) & Chr(10) & Chr(10)
        b_atxt = b_atxt & "Data:" & Chr(13) & Chr(10)
       
        'to assign the variable data to b_text with hyphens and linebreaks
        For x = (cnum1 + 1) To (x_max)
            b_atxt = b_atxt & "- " & R_data(x) & Chr(13) & Chr(10)
        Next x
        b_atxt = b_atxt & Chr(13) & Chr(10)
       
        'to add the slogan 2 to b_atext
        b_atxt = b_atxt & R_data(cnum1 - 3) & Chr(13)
       
       
        'to add slogan 3 & 4 to b_btxt
            b_btxt = R_data(cnum1 - 2) & Chr(13) & Chr(10) & Chr(10)
            b_btxt = b_btxt & R_data(cnum1 - 1) & Chr(13) & Chr(10)
       
        'to write all of b_text to cell A1, A2 etc on the loop
        Sheets(b_tab).Cells(y, 1) = b_atxt
       
        'to write all of b_btxt to cell B1, B2 etc on the loop
        Sheets(b_tab).Cells(y, 2) = b_btxt
       
    Next y

    Sheets(b_tab).Select
    Application.ScreenUpdating = True
   
   
End Sub