I have this kind of data in my excel .from this I want see my required output as below with help of VBA script.

Question

1.00/5 (2 votes)

See more:

a	1	2	3								
b	1	2	3								
c	1	2	3

a	1	16	17								
b	12	15	16								
c	13	14	17

I have this kind of data in my excel .From this I want see my required output as below with help of vba script.

Required op:

Thanks In advance.

What I have tried:

VB

Option Explicit

Public Sub NormaliseData()

    Dim myRange, myDest, r As Range, i, n As Long
    
    'Change this range to encompass all your data
    Set myRange = Worksheets("Sheet5").Range("A1:D7")
    
    'Change this range to show where to start the new list
    Set myDest = Worksheets("Sheet6").Range("A1")
    
    With myRange
        For i = 1 To .Rows.Count
            For Each r In .Range(.Cells(i, 1), .Cells(i, .Columns.Count))
                If r.Column = myRange.Column Then
                    myDest.Value = r.Value
                ElseIf r.Value <> "" Then
                    myDest.Offset(0, 1).Value = r.Value
                    Set myDest = myDest.Offset(1, 0)
                Else
                    'do nothing
                End If
            Next r
        Next i
    End With

End Sub

Posted 7-Sep-16 21:26pm

Member 12726897

Updated 8-Sep-16 5:08am

Maciej Los

v3

Add a Solution

Comments

Patrice T 8-Sep-16 3:35am

And you plan to explain what is the problem ?

2 solutions

Add a Solution

Add your solution here

Treat my content as plain text, not as HTML

Preview 0

…

Existing Members

Sign in to your account

...or Join us

Download, Vote, Comment, Publish.

Your Email
Password
Forgot your password?

Your Email
This email is in use. Do you need your password?
Optional Password

I have read and agree to the Terms of Service and Privacy Policy
Please subscribe me to the CodeProject newsletters

When answering a question please:

Read the question carefully.
Understand that English isn't everyone's first language so be lenient of bad spelling and grammar.
If a question is poorly phrased then either ask for clarification, ignore it, or edit the question and fix the problem. Insults are not welcome.
Don't tell someone to read the manual. Chances are they have and don't get it. Provide an answer or move on to the next question.

Let's work to help developers, not make them feel stupid.

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

GoodJuJu · Answer 1 · 2016-09-07T22:49:00

Solution 1

Will simply 'transposing' the data work for you?

Public Sub NormaliseData()
 
    Dim myRange, myDest, r As Range, i, n As Long
    
    'Change this range to encompass all your data
    Set myRange = Worksheets("Sheet5").Range("A1:D7")
    
    'Change this range to show where to start the new list
    Set myDest = Worksheets("Sheet6").Range("A1")
    
    myRange.Copy
    myDest.PasteSpecial Transpose:=True

End Sub

Posted 7-Sep-16 22:49pm

GoodJuJu

Comments

Member 12726897 8-Sep-16 5:01am

By executing above code It's returning output as below.
a b c a b c
1 1 1 1 12 13
2 2 2 16 15 14
3 3 3 17 16 17

But I want the op as follows

a b c
1 1 1
2 2 2
3 3 3
1 12 13
16 15 14
17 16 17

Thanks in advance.

GoodJuJu 8-Sep-16 5:13am

Is that your actual data, a b c... or is there a specific header that changes with each 'batch'?

GoodJuJu · Answer 2 · 2016-09-07T23:28:00

Okay - try this:

Option Explicit
 
Public Sub NormaliseData()
 
    Dim rngSource, rngDest As Range
    Dim intRow As Integer
    
    Dim strSourceSheet As String
    Dim strDestSheet As String
    
    strSourceSheet = "Sheet5"
    strDestSheet = "Sheet6"
    
    Worksheets(strSourceSheet).Select
    
    For intRow = 1 To Worksheets(strSourceSheet).UsedRange.Rows.Count
        If Worksheets(strSourceSheet).Range("A" & intRow).Value Like "a" Then
            If intRow = 1 Then
                Set rngSource = Worksheets(strSourceSheet).Range("A" & intRow & ":D" & intRow + 2)
            Else
                Set rngSource = Worksheets(strSourceSheet).Range("B" & intRow & ":D" & intRow + 2)
            End If
            
            Call fncTranspose(rngSource, rngDest, intRow, strDestSheet)
            
        End If
    Next intRow
    
MsgBox "Values have been transposed", vbOKOnly, "Transposed"
End Sub

Function fncTranspose(rngSource, rngDest, intRow, strDestSheet)

Dim intLastDestRow As Integer
intLastDestRow = Worksheets(strDestSheet).UsedRange.Rows.Count

Worksheets(strDestSheet).Select

If intRow = 1 Then
    Set rngDest = Worksheets(strDestSheet).Range("A" & intLastDestRow)
    rngSource.Copy
    rngDest.PasteSpecial Transpose:=True
Else
    Set rngDest = Worksheets(strDestSheet).Range("A" & intLastDestRow + 1)
    rngSource.Copy
    rngDest.PasteSpecial Transpose:=True
End If

End Function