• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Selecting and putting data in columns

tazz

tazz

Member
Hello all,

I need help with a VBA code able to select and put data in columns as shown in the attached example.

Thank you for your help
 

Attachments

Hi Tazz,

Looked at your file, is the BEFORE one set of data, and how do you differentiate between what goes where, in other words how do you decide that any particular cell will go into another cell on AFTER.

You have all the colours on AFTER, how do you decide what colour any of the cells is, so why are the green cells green and the same question for all the colours.

kanti
 
Hi, tazz!
Nice puzzle, with instructions in other languages than Mandarin or Russian maybe it'd be able to get understood at least, if not solved. Would you mind elaborating?
Regards!
 
hello,
As I said, those colors are only for visual purpose. I don't need them, I put it there for those who would like to help in order to differentiate between data. There are 4 sets of data:
1. 1 cell numbers and another cell combination(Pink)
2. 3 cells all numbers(green)
3.2 cells w/ numbers(blue)
4. 1 cell Combination and 1 cell number( grey)
Cells with yellow are only with residual data that I don't need( no data in BB)
Thank You for your help and time.
 
Hi, tazz!
Thanks for the clarification, 3 more things:
a) All the data is in adjacent columns, without any embedded spaces? Just to discard cases as or rows 15:18 because of BB cells, no matter what might be in BC or righter cells.
b) Only the 4 described combinations are valid to be copied?
c) Only 2nd one might have 3 values instead of 2? Or any combinations can be of any length? If so, which cell column apart from the 2nd should be taken to perform the checkings?
Regards!
 
Hi SirJB7,
You are correct in your assumptions:
a. discard all cases without data in BB (data like in rows 2:6 included). No BB data means I don't need information from cells left and right
b. there are only 4 combination
c. only 2nd one has 3 values
For the other 3 cases values in BA are different and this could be another criteria of checking.

Thank you
 
Hi, tazz!

Give a look at the uploaded file. It uses a few dynamic named ranges for easier referencing:
SourceTable: =DESREF('Before&After'!$BA$2;;;CONTARA('Before&After'!$BA:$BA)-1;3) -----> in english: =OFFSET('Before&After'!$BA$2,,,COUNTA('Before&After'!$BA:$BA)-1,3)
TargetTable: =DESREF('Before&After'!$BF$1;;;MAX(CONTARA('Before&After'!$BF:$BF);CONTARA('Before&After'!$BH:$BH);CONTARA('Before&After'!$BK:$BK);CONTARA('Before&After'!$BM:$BM));9) -----> in english: =OFFSET('Before&After'!$BF$1,,,MAX(COUNTA('Before&After'!$BF:$BF),COUNTA('Before&After'!$BH:$BH),COUNTA('Before&After'!$BK:$BK),COUNTA('Before&After'!$BM:$BM)),9)
Target1Table: =DESREF(TargetTable;;0;CONTARA('Before&After'!$BF:$BF);2) -----> in english: =OFFSET(TargetTable,,0,COUNTA('Before&After'!$BF:$BF),2)
Target2Table: =DESREF(TargetTable;;2;CONTARA('Before&After'!$BH:$BH);3) -----> in english: =OFFSET(TargetTable,,2,COUNTA('Before&After'!$BH:$BH),3)
Target3Table: =DESREF(TargetTable;;5;CONTARA('Before&After'!$BK:$BKF);2) -----> in english: =OFFSET(TargetTable,,5,COUNTA('Before&After'!$BK:$BK),2)
Target4Table: =DESREF(TargetTable;;7;CONTARA('Before&After'!$BM:$BM);2) -----> in english: =OFFSET(TargetTable,,7,COUNTA('Before&After'!$BM:$BM),2)

This is the code:
Code: 
Option Explicit

Sub StrangeFormOfTransposingLikeTazmanianDevil()
    ' constants
    Const ksSourceWS = "Before&After"
    Const ksSourceRng = "SourceTable"
    Const ksTargetWS = "Before&After"
    Const ksTargetRng = "TargetTable"
    Const ksTargetNRng = "Target0Table"
    Const ksTargetN = "0"
    Const kiTargetN = 4
    Const ksNumbers = "0123456789-"
    ' declarations
    Dim rngS As Range, rngT As Range, c As Range, rngTN(kiTargetN) As Range
    Dim lIndex(kiTargetN) As Long
    Dim I As Long, J As Long, K As Integer, A As String
    ' start
    Set rngS = Worksheets(ksSourceWS).Range(ksSourceRng)
    Set rngT = Worksheets(ksTargetWS).Range(ksTargetRng)
    With rngT
        If .Rows.Count > 2 Then Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
    End With
    For I = 1 To kiTargetN
        Set rngTN(I) = Worksheets(ksTargetWS).Range(Replace(ksTargetNRng, ksTargetN, CStr(I)))
        lIndex(I) = 1
    Next I
    ' process
    With rngS
        I = 1
        Do Until .Cells(I, 1).Value = ""
            Set c = .Cells(I, 1)
            If c.Offset(0, 1).Value <> "" Then
                J = 0
                ' case 1: 2 cols, number and anything
                If J = 0 Then
                    If IsNumeric(c.Value) And Not (IsNumeric(c.Offset(0, 1).Value)) Then
                        J = 1
                    End If
                End If
                ' case 2: 3 cols, numbers
                If J = 0 Then
                    If IsNumeric(c.Value) And IsNumeric(c.Offset(0, 1).Value) And _
                      IsNumeric(c.Offset(0, 1).Value) Then
                        J = 2
                    End If
                End If
                ' case 3: 2 cols, number with dash and number
                If J = 0 Then
                    For K = 1 To Len(c.Value)
                        If InStr(ksNumbers, Mid(c.Value, K, 1)) = 0 Then Exit For
                    Next K
                    If K > Len(c.Value) Then
                        J = 3
                    End If
                End If
                ' case 4: 2 cols, letter&number and number
                If J = 0 Then
                    If Not (IsNumeric(c.Value)) And IsNumeric(c.Offset(0, 1).Value) Then
                        J = 4
                    End If
                End If
                '
                If J > 0 Then
                    lIndex(J) = lIndex(J) + 1
                    Range(c, c.End(xlToRight)).Copy rngTN(J).Cells(lIndex(J), 1)
                End If
            End If
            I = I + 1
        Loop
    End With
    ' end
    For I = 1 To kiTargetN
        Set rngTN(I) = Nothing
    Next I
    Set rngT = Nothing
    Set rngS = Nothing
    Beep
End Sub

Just advise if any issue.

Regards!
 
Hi, SirJB7
thank you so much for your help. I will give it a try and I will let you know how is working.
I really appreciate your time you put in to solve this puzzle.
Thank you
 
Hi, SirJB7
This is what I did: I put your code into a module and I run it. There is a message of error:Subscript out of range.
The yellow line in code is: Set rngS=Worksheet(KsSourceWS).Range(KsSourceRng)
Is there anything that I should change in order to make this code working?
Thank you for your help
 
SirJB7 said:
Give a look at the uploaded file. It uses a few dynamic named ranges for easier referencing:
SourceTable: =DESREF('Before&After'!$BA$2;;;CONTARA('Before&After'!$BA:$BA)-1;3) -----> in english: =OFFSET('Before&After'!$BA$2,,,COUNTA('Before&After'!$BA:$BA)-1,3)
TargetTable: =DESREF('Before&After'!$BF$1;;;MAX(CONTARA('Before&After'!$BF:$BF);CONTARA('Before&After'!$BH:$BH);CONTARA('Before&After'!$BK:$BK);CONTARA('Before&After'!$BM:$BM));9) -----> in english: =OFFSET('Before&After'!$BF$1,,,MAX(COUNTA('Before&After'!$BF:$BF),COUNTA('Before&After'!$BH:$BH),COUNTA('Before&After'!$BK:$BK),COUNTA('Before&After'!$BM:$BM)),9)
Target1Table: =DESREF(TargetTable;;0;CONTARA('Before&After'!$BF:$BF);2) -----> in english: =OFFSET(TargetTable,,0,COUNTA('Before&After'!$BF:$BF),2)
Target2Table: =DESREF(TargetTable;;2;CONTARA('Before&After'!$BH:$BH);3) -----> in english: =OFFSET(TargetTable,,2,COUNTA('Before&After'!$BH:$BH),3)
Target3Table: =DESREF(TargetTable;;5;CONTARA('Before&After'!$BK:$BKF);2) -----> in english: =OFFSET(TargetTable,,5,COUNTA('Before&After'!$BK:$BK),2)
Target4Table: =DESREF(TargetTable;;7;CONTARA('Before&After'!$BM:$BM);2) -----> in english: =OFFSET(TargetTable,,7,COUNTA('Before&After'!$BM:$BM),2)
Click to expand...
Hi, tazz!
Have you defined these named ranges and adjusted to your actual worksheet names?
If not, then try again after doing it. Otherwise consider uploading a sample file.
Regards!
 
Hi, SirJB7
I tried my best to make this macro running but...it was not enough.
Please take a look in the attached file and, if your time allows you, give it a try.
Thank you and
"Happy New Year!!!"
 

Attachments

Hi, tazz!
Glad you solved it. Thanks for your feedback and for your kind words too. And welcome back whenever needed or wanted.
Regards!
 
Hi SirJB7
I came back with one more thing.
I am so happy with this macro, I have decided to apply it to multiple sheets into a workbook(one by one). So I tried to change "DATA1" into "ActiveSheet" hoping that will solve the problem. Could you please help on this one also?
Thank you for your time.
 
Hi, tazz!

You can't change the worksheet names to "ActiveSheet" (as you previously did) since there's no worksheet with that name. I don't know which is the structure of your actual workbook (worksheets, where data is stored, etc.), I don't even know if you're planning to keep the output data aside to the input data or you'll be extracting it to other worksheets (that's why there're 2 constants, one for the input WS -ksSourceWS- and another for the output WS -ksTargetWS-.

Said so, if you want to run the macro always on the active sheet of the workbook (for both input and output data areas), you should make this changes:

Code: 
    Set rngS = Worksheets(ksSourceWS).Range(ksSourceRng)
    Set rngT = Worksheets(ksTargetWS).Range(ksTargetRng)
by this:
Code: 
    Set rngS = Activesheet.Range(ksSourceRng)
    Set rngT = Activesheet.Range(ksTargetRng)

Code: 
        Set rngTN(I) = Worksheets(ksTargetWS).Range(Replace(ksTargetNRng, ksTargetN, CStr(I)))
by this:
Code: 
        Set rngTN(I) = Activesheet.Range(Replace(ksTargetNRng, ksTargetN, CStr(I)))

But you'll have to define all the 6 dynamic named ranges with worksheet scope and not with workbook (default) scope, in every worksheet where you want to run the macro. Which I think it'd be a bit (a lot!) hard & tricky, depending on the no. of worksheets.

Regards!
 
Hi SirJB7,

it's like your food shopping list, Calsberg is always hardcoded on top ‼ :DD

ReCarlsGardsBerg ! (some secret MI6 language !)​
 
Hi, Marc L!

Years ago I went on holidays to Brazil where I have cousins, and before spending a few days with them I rested for a week at the beach. There I bought a few T-shirts and one of them has printed this: "Eu bebo porque é liquido... se fosse sólido eu comia" (I drink because it's liquid, if it's solid I'd eat it). It sounded nice and it was a touch of humor. When I arrived to my cousins' home, they were waiting me with the protocol indicated caipiroskas, and after the greetings they asked me if I knew which was the origin of the phrase in my T-shirt. I told them that I thought it was one of the guys at these sites:
http://filosofosbebados.blogspot.com.ar/2008/08/bebo-porque-liquido-se-fosse-slido-com.html
https://www.facebook.com/BeboPorqueELiquidoSeFosseSolidoEuComia
All of them smiled and told me that it was an actual phrase of their former Sao Paulo's Major (-1988) and Brazilian's president in 1961, Jânio Quadros. I thought they were joking and I returned with that doubt. That was the dark era before internet, so as in Microsoft Encarta and other stuffs there was nothing about it, and the whole thing got stored somewhere in my brain.

Many years later, I'd say after 2005, I stumped into that phrase in the internet, I obviously searched for it and I found this about that man (today links):
https://en.wikipedia.org/wiki/Jânio_Quadros
Til now everything's fine, even with wikiquote in English:
https://en.wikiquote.org/wiki/Jânio_Quadros
But check wikiquote in Brazilian Portuguese:
https://pt.wikiquote.org/wiki/Jânio_Quadros

Look at the 2nd quote, there was my shirt!

And the 3rd one "I disinfect because undue buttocks sat on it" regarding a chair where his rival had been seated before the elections,...

And the 4th one "Lies! Sound doesn't propagate in vacuum" when in a presidential speech an opposition politician told him "can speak, your words go in one ear and out the other"...

ReCarlsGardsBerg!

PS: So it's time to update my profile. Chapeau, Jânio!
 
Last edited:
Hi, tazz!
Glad you solved it. Thanks for your feedback and welcome back whenever needed or wanted.
Regards!
 
You must log in or register to reply here.
Back
Top