Auto Transpose macro

[monda24]

Hello there,
I really hope someone can help me with this macro that I tried to create and gave up.
I tried the record macro option and modified the values on the script,but considering the knowledge that I have in excel, it didnot work.
Am trying to create an excel sheet,which, upon one click transposes the 1000 values in 1000 rows(1column) in to single row of 1000 columns.
I cannot paste 2000 values here so am giving an example of 100 values, 50 in one row >then a blank row, then 50.
(so what I actually am looking for is 1000 in one row,blank row>next thousand and so on)
Sometimes, the work we do goes on till 50,000 values to 100000, so it gets difficult.

Example :

Company id

10084410
10110378
11247324
21542065
52p50728
5starf02
5starr07
99034442
aacqst08
aaj04821
aba58774
abc28803
abr85711
abs05863
abukio06
acc10045
acc52500
acchur05
accntl04
accord00
accwci04
ace47732
ace73418
acedde05
acmebc02
aconex08
acr46344
adamsn01
addllc09
ade77627
adtein03
adu74034
adv04788
adv25200
adv60376
adv80105
advfun02
aer23415
aew65323
aff66377
afminc09
africa02
aga55862
agr63845
agrico08
aha80181
ahmoco02
air32040
airint03
airscn04
ajemex09
akfain09
alb64555
albhea04
ald36083
aldrey04
ale04513
algboe09
algosi04
all50435
alp12485
alp58881
alprbs09
alsele04
alsinc05
alterm08
alz55888
amb42163
amclos99
amdjap05
ame16612
ame43768
ame46305
ame67558
ame75681
americ09
amp78733
amplif03
amtekm03
anarco02
anc58283
and43362
andhra08
anesth08
ang24032
ansfmt09
ant06221
anthcn02
anthcn04
anthcn06
anthcn08
anthcn10
anthes03
anthes05
anthes07
anthes09
anthws03
anthws05
anthws07

Result :

first 50 values,(am not able to paste them here in one row)
Insert blank row
Next 50 values,(am not able to paste them here in one row)

Thank you very much in advance.

 

[monda24]

sorry the correct link is "https://www.mediafire.com/?9bd96m69e8zbmh9" , the file name is correct file..

 

[apo]

Hi..

Is this what you want?

Private Sub CommandButton1_Click()
'Transposed to Sheet2 with a Blank Row between each Row
Dim rng As Range, j As Long
    j = 2
    With Sheets("Sheet1")
      .Range("A3:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row Step 1000
            Set rng = .Range(Cells(i, 1), Cells(i + 1000, 1))
            Sheets("Sheet2").Cells(j, 1).Resize(1, rng.Count - 1) = Application.Transpose(rng)
            j = j + 2
        Next i
    End With
    Sheets("Sheet2").Select
End Sub

Private Sub CommandButton3_Click()
'Transposed to Sheet3 - comma seperated - no blank row
Dim rng As Range, j As Long
    j = 2
    With Sheets("Sheet1")
      .Range("A3:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row Step 1000
            Set rng = .Range(Cells(i, 1), Cells(i + 1000, 1))
            Sheets("Sheet3").Cells(j, 1).Resize(1, rng.Count - 1) = Join(Application.WorksheetFunction.Transpose(rng.Value), ",")
            j = j + 1
        Next i
    End With
    Sheets("Sheet3").Select
End Sub

 

[monda24]

Hi..

Is this what you want?

Private Sub CommandButton1_Click()
'Transposed to Sheet2 with a Blank Row between each Row
Dim rng As Range, j As Long
    j = 2
    With Sheets("Sheet1")
      .Range("A3:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row Step 1000
            Set rng = .Range(Cells(i, 1), Cells(i + 1000, 1))
            Sheets("Sheet2").Cells(j, 1).Resize(1, rng.Count - 1) = Application.Transpose(rng)
            j = j + 2
        Next i
    End With
    Sheets("Sheet2").Select
End Sub

Private Sub CommandButton3_Click()
'Transposed to Sheet3 - comma seperated - no blank row
Dim rng As Range, j As Long
    j = 2
    With Sheets("Sheet1")
      .Range("A3:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row Step 1000
            Set rng = .Range(Cells(i, 1), Cells(i + 1000, 1))
            Sheets("Sheet3").Cells(j, 1).Resize(1, rng.Count - 1) = Join(Application.WorksheetFunction.Transpose(rng.Value), ",")
            j = j + 1
        Next i
    End With
    Sheets("Sheet3").Select
End Sub

Hello Apo, 'Transposed to Sheet2 with a Blank Row between each Row " macro is absoultely fine.
However, the second macro i.e., the macro without a blank row should give results in sheet 2 (not on sheet 3 and also, in the first row it is giving me 1001 values(1000+default value),where as I would need 1000 values only (1 would be the default value) so A2+999 values..please help

 

[monda24]

Hello Apo, 'Transposed to Sheet2 with a Blank Row between each Row " macro is absoultely fine.
However, the second macro i.e., the macro without a blank row should give results in sheet 2 (not on sheet 3 and also, in the first row it is giving me 1001 values(1000+default value),where as I would need 1000 values only (1 would be the default value) so A2+999 values..please help

On the result sheet on the first row I get 1001 values..it should be the default value+the next 999 sorted values.

 

[monda24]

So the value in A2 should not get sorted or checked for duplicacy but should get transposed..is ti possible?

 

[apo]

This should do it..

I added the remove duplicates function ( i forgot about that)..

the macro without a blank row should give results in sheet 2 (not on sheet 3

You should look at the code and see that all that was needed was to change "Sheet3" to "Sheet2"..

Note: When you look at the results of the comma delimited Sub.. you will only see 1024 characters in the cell (max Excel limit)... but you will see ALL characters in the address bar..

Private Sub CommandButton1_Click()
'Transposed to Sheet2 with a Blank Row between each Row
Dim rng As Range, j As Long
    j = 2
    With Sheets("Sheet1")
    .Range(Range("A3"), Range("A3").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
      .Range("A3:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row Step 1000
        If i = .Range("A" & Rows.Count).End(xlUp).Row Then Exit Sub
            Set rng = .Range(Cells(i, 1), Cells(i + 1000, 1))
            Sheets("Sheet2").Cells(j, 1).Resize(1, rng.Count - 1) = Application.Transpose(rng)
            j = j + 2
        Next i
    End With
    Sheets("Sheet2").Select
End Sub

Private Sub CommandButton3_Click()
'Transposed to Sheet3 - comma seperated - no blank row
Dim rng As Range, j As Long
    j = 2
    With Sheets("Sheet1")
    .Range(Range("A3"), Range("A3").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
      .Range("A3:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlNo
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row Step 1000
            Set rng = .Range(Cells(i, 1), Cells(i + 999, 1))
            Sheets("Sheet2").Cells(j, 1).Value = Join(Application.WorksheetFunction.Transpose(rng.Value), ",")
            j = j + 1
        Next i
    End With
    Sheets("Sheet2").Select
End Sub

 

[monda24]

Hello Apo! I was able to get the expected results with both the macros!!Thank you very much!
Yes I was not able to change the values and get the results at my workplace, later I went home and tried and was able to. Sorry if I was very quizzical.
Finally, one question,lol, can't I transpose the value in A2 which is default if I lock that cell..I tried locking A2 which has a default value always and tried the code, it didnot work, when I didnot lock it, it worked..so cant I lock the cell and apply formula?

 

[apo]

Hi..

I guess you could always Unprotect your sheet .. then do your stuff.. then protect the sheet again once done..

Something like this (you will need to change some things like sheet name and password to suit your particular case)..

       ' Test if sheet is Protected
            If sh.ProtectContents = True Then
                flg = 1
                sh.Unprotect Password:="yourpassword"
            End If


[B]         ' Do your stuff[/B]
             


             'Reprotect Sheet (if it was Protected in the first place).
            If flg = 1 Then
                sh.Protect Password:="yourpassword"
            End If
            flg = 0

 

[monda24]

Hello Apo! Hope you are well. sorry I was off track for a while..I ve tried the macro and it has helped me and my team alot! I cannot thank you enough.All the very best for the knowledge sharing that you do..way to go Cheers!

 

[monda24]

hello Apo,

Hope you are well.
I was asked to make a few changes to the sheet that you made it..
1. When I paste the values in sheet 1 , the duplicate values should get highlighted and the total number of duplicate values should show in D8 and the number of non duplicate values should show in D9..example : out of 2500 values, 120 values are duplicate, then D8 should have 120 and D9 should have 2380.
2.Also is there a possibility that the comas should stop with the last value on sheet 2?like if there are less than 1000 values , say 500, then the sheet is givng me 500 transposed values+500 comas..I need 999 values+svcdlvcpo(that is the limit).However, if there are only200 values,then I get 800 comas..can this be done?
3. Am sorry