Find colums vba code needed

[gnusmas]

I need vba code!

Exemple i have the following columns and i want to extract columns just they get : 06, 15, 43

Sheet 1

01	01	03	02	01	04	04	01	03	04
03	06	04	06	02	05	05	05	05	06
06	08	06	08	06	06	06	06	06	07
07	14	09	11	10	11	08	08	10	08
12	16	12	12	12	14	11	10	13	12
13	17	13	13	17	17	14	13	15	19
15	20	16	16	18	20	17	14	16	22
18	24	18	20	21	21	20	15	18	25
19	30	20	21	22	22	21	20	20	27
28	32	22	23	25	23	23	22	21	28
29	37	25	28	29	25	25	29	29	31
31	39	26	31	30	27	27	30	32	33
32	41	29	33	31	29	29	31	33	34
33	42	31	34	37	30	30	35	35	36
34	43	32	35	38	31	31	36	39	43
35	44	38	36	39	35	33	37	41	44
43	47	42	37	43	40	40	38	42	46
46	49	43	40	44	43	43	43	43	47
47		46	43	45	44	46	47	44
49		47	47	46	47	47	49	47
		48		47	48	48
				48
				49

<tbody>
</tbody>

Sheet 2 output

01	01	03
03	05	05
06	06	06
07	08	10
12	10	13
13	13	15
15	14	16
18	15	18
19	20	20
28	22	21
29	29	29
31	30	32
32	31	33
33	35	35
34	36	39
35	37	41
43	38	42
46	43	43
47	47	44
49	49	47

<tbody>
</tbody>

Thank for help!

 

[gnusmas]

Yes "02" is the actual number two formatted to show a leading zero.
thank very much for your help

 

[hiker95]

gnusmas,

The following macro will ask for three numbers with a single space character between the three numbers.

For the below example, I entered:
2 5 8


Sample raw data in worksheet Sheet1:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W
1	02	02	01	02	02	08	01	02	01	02	01	03	03	01	03	02	02	02	02	01	02	02
2	03	06	10	06	11	11	02	03	02	03	08	05	05	05	05	03	04	03	03	02	04	07
3	04	10	13	09	12	17	03	08	04	05	09	07	08	13	07	05	06	04	04	03	05	09
4	09	13	15	11	13	19	06	11	05	07	10	09	14	14	10	08	10	05	05	06	11	10
5	10	14	19	13	15	21	09	12	13	08	11	11	15	15	12	09	15	16	06	07	12	14
6	18	15	21	19	16	24	11	15	15	13	13	12	16	16	13	10	18	20	12	08	13	15
7	21	16	23	21	26	25	14	17	16	14	15	13	20	21	14	12	20	22	13	09	16	16
8	23	17	24	22	29	26	16	18	17	22	17	14	22	26	15	13	22	23	14	14	18	17
9	24	18	25	25	31	27	22	20	19	23	18	21	23	28	16	14	23	24	16	20	19	19
10	25	23	28	28	32	28	26	22	20	25	20	22	26	30	21	16	24	25	18	25	20	21
11	28	24	30	29	35	31	28	24	27	29	23	27	28	33	22	19	25	26	21	30	25	22
12	29	25	32	38	38	41	29	25	30	31	24	29	31	35	23	20	30	27	23	33	31	25
13	31	27	37	39	39	43	31	30	31	35	26	30	32	37	24	24	31	28	27	38	32	26
14	34	30	38	40	42	45	32	31	38	36	30	32	34	39	25	32	32	31	28	42	33	29
15	35	32	39	41	43	46	35	36	39	37	31	36	35	40	27	34	33	32	33	43	34	31
16	36	33	40	42	45	47	40	40	41	39	32	39	40	43	28	36	34	35	34	44	38	32
17	42	34	41	46	46	48	42	41	43	44	38	40	43	46	32	42	35	36	40	45	39	33
18	43	36	42	47	47	49	46	45	44	45	40	45	45	48	33	46	40	40	41	46	44	38
19	44	46	46	48	48		47	46	45	46	44	46	46	49	36		42	43	46	48	46	41
20	46	48	48				49	47	46		46	48			46		45	46	47	49	48	43
21	49							48			48						46	48	48			46
22								49											49
23
Sheet1

After the macro in worksheet Sheet2:

Excel 2007
	A	B	C
1	02	02
2	03	03
3	05	05
4	07	08
5	08	09
6	13	10
7	14	12
8	22	13
9	23	14
10	25	16
11	29	19
12	31	20
13	35	24
14	36	32
15	37	34
16	39	36
17	44	42
18	45	46
19	46
20
Sheet2

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub GetColumnsV3()
' hiker95, 09/30/2014, ME808154
Dim w1 As Worksheet, w2 As Worksheet
Dim lr As Long, lc As Long, nc As Long, c As Long
Dim n1 As Long, n2 As Long, n3 As Long, tns As String, n As Long
Dim s, i As Long, nlr As Long
Dim n1r As Range, n2r As Range, n3r As Range
tns = InputBox("Enter the 3 numbers " & vbLf & " separated by a single space character.")
n = Len(tns) - Len(WorksheetFunction.Substitute(tns, " ", ""))
If n <> 2 Then
  MsgBox "You have entered the incorrect string '" & tns & "' - macro terminated!"
  Exit Sub
End If
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
w2.UsedRange.ClearContents
s = Split(tns, " ")
n1 = s(0): n2 = s(1): n3 = s(2)
With w1
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  For c = 1 To lc
    Set n1r = .Columns(c).Find(n1, LookAt:=xlWhole)
    Set n2r = .Columns(c).Find(n2, LookAt:=xlWhole)
    Set n3r = .Columns(c).Find(n3, LookAt:=xlWhole)
    If (Not n1r Is Nothing) * (Not n2r Is Nothing) * (Not n3r Is Nothing) Then
      nc = nc + 1
      nlr = .Cells(Rows.Count, c).End(xlUp).Row
      w1.Range(w1.Cells(1, c), w1.Cells(nlr, c)).Copy Destination:=w2.Range(w2.Cells(1, nc), w2.Cells(nlr, nc))
      Application.CutCopyMode = False
    End If
    Set n1r = Nothing
    Set n2r = Nothing
    Set n3r = Nothing
  Next c
End With
With w2
  .Columns(1).Resize(, nc).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the GetColumnsV3 macro.

 

[Peter_SSs]

This would allow you to enter any number of numbers you want to match. Omit leading zeros when entering the numbers.

Sub GetCols()
  Dim a, b
  Dim i As Long, j As Long, k As Long, x As Long, y As Long, rws As Long, LookFor As Long
  Dim Found As String, Crit As String
  
  Crit = InputBox("Enter search numbers separated by spaces. Omit leading zeros")
  If Len(Crit) > 0 Then
    LookFor = UBound(Split(Crit)) + 1
    Crit = " " & Crit & " "
    a = Sheets("Sheet1").UsedRange.Value
    rws = UBound(a, 1)
    ReDim b(1 To rws, 1 To 1)
    For j = 1 To UBound(a, 2)
      k = 0
      Found = " "
      For i = 1 To rws
        If InStr(1, Crit, " " & a(i, j) & " ", 1) > 0 Then
          If InStr(1, Found, " " & a(i, j) & " ", 1) = 0 Then
            k = k + 1
            If k = LookFor Then
              x = x + 1
              ReDim Preserve b(1 To rws, 1 To x)
              For y = 1 To rws
              b(y, x) = a(y, j)
              Next y
              Exit For
            End If
            Found = Found & a(i, j) & " "
          End If
        End If
      Next i
    Next j
    With Sheets("Sheet2")
      .UsedRange.ClearContents
      If x > 0 Then
        .Range("A1").Resize(rws, x).Value = b
      End If
      .Activate
    End With
  End If
End Sub

 

[gnusmas]

Great job friends !!
here i just need vba code to delete last line of each group!!

Sheet 1

05	06	31	39	44	49
06	18	22	29	37	44
04	08	12	16	27	44
09	24	26	37	44	46
05	20	21	26	31	47
08	10	22	26	31	37
08	14	26	36	39	42
05	09	34	38	39	42
04	22	27	36	38	46
06	21	22	37	41	42
03	16	18	19	37	42
07	10	22	25	32	43
02	19	25	30	32	39
01	12	14	31	32	46
10	19	21	24	33	35

<colgroup><col span="6"></colgroup><tbody>
</tbody>

Sheet 2 output like this

05	06	31	39	44	49
06	18	22	29	37	44
04	08	12	16	27	44
09	24	26	37	44	46
08	10	22	26	31	37
08	14	26	36	39	42
05	09	34	38	39	42
04	22	27	36	38	46
03	16	18	19	37	42
07	10	22	25	32	43
02	19	25	30	32	39
01	12	14	31	32	46

<colgroup><col span="6"></colgroup><tbody>
</tbody>

I apreciate so much your help!

 

[hiker95]

gnusmas,

Thanks for the feedback.

You are very welcome. Glad we could help.

here i just need vba code to delete last line of each group!!

I would suggest that you start a NEW thread for your very different new request.

 

[Peter_SSs]

I would suggest that you start a NEW thread for your very different new request.

Refer here

 

[hiker95]

Peter_SSs,

Thanks for the link.