Excel first timer Macro user

Z

ZaXaZ

New Member
Joined
Feb 16, 2015
Messages
24
Hi, this is my first time having the need of a macro and it´s a bit overwhelming.
i started a new work and lets just say that no on here is very sharp when it comes to pc or what you can do with it most of the times.

so i get a list of car Models and types of the model in a txt doc witch most of the time is very long 100+ sometimes 10+ or 1000+. but it´s given to me in a very bad form and takes quite some time to do manual ea time..

and any one here help me with making a macro?

here is a very short example, of what i get to work with, and what i need to end up with :)
Model: Type
405: 101 103 121 123 201 221
900: 911 912 913 917 918 919 922 934 936 937 938
list goes one feels like its endless..

i need it to be made to
type Model
405 101
405 102
405 121
405 123
405 201
405 221

900 911
900 912
900 913
900 917
900 918
900 919
900 922
900 934
900 936
900 937
900 938
 
Last edited:
Sort by date Sort by votes
hiker95 said:
ZaXaZ,



Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.




Can we have another link, like the one above, where you manually format the results, in the correct locations/columns/new worksheet?


After you do the above, I would be happy to insert comment lines in the final macro code, so that you would be able to understand/follow what is going on.
Click to expand...


Here it is, my dream end result :)
https://www.dropbox.com/s/nn6s7lzduj62s1s/end result.xlsx?dl=0 (dropbox.com/s/nn6s7lzduj62s1s/end%20result.xlsx?dl=0)
 
Upvote 0

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Just one slight addition.

If you run this on a blank sheet the macro will ask you to select the text file and then import based on your OP.

Code: 
Sub ImportxtFile()


    Dim LineString As String
    Dim sSourceFile As String
    Dim sSepChar As String
    Dim r As Long
    Dim fLen As Long
    Dim fn As Integer
    Dim TypeStr As String
    Dim ModelArr As Variant
    Dim i As Long


    sSourceFile = Application.GetOpenFilename("Text Files (*.txt), *.txt")


    If Len(Dir(sSourceFile)) = 0 Then Exit Sub

    fn = FreeFile


    Open sSourceFile For Input As #fn
    On Error GoTo 0
    fLen = LOF(fn)
    r = 1
    While Not EOF(fn)
        Line Input #fn, LineString
        TypeStr = Left(LineString, InStr(1, LineString, ": ") - 1)
        ModelArr = Split(Replace(LineString, Left(LineString, InStr(1, LineString, ": ") + 1), ""), " ")
        For i = LBound(ModelArr) To UBound(ModelArr)
            Cells(r, 1).Value = TypeStr
            Cells(r, 2).Value = ModelArr(i)
            r = r + 1
        Next i
        r = r + 1
    Wend


    Close #fn
Rows(2).Delete 'to be removed if original file has no headers.
End Sub

I've assumed that your source Text file contains headers if it doesn't remove the last line.

Excel 2010
AB
1TypeModel
2405101
3405103
4405121
5405123
6405201
7405221
8
9900911
10900912
11900913
12900917
13900918
14900919
15900922
16900934
17900936
18900937
19900938

<tbody>
</tbody>
Sheet1​
 
Last edited:
Upvote 0
Comfy said:
Just one slight addition.

If you run this on a blank sheet the macro will ask you to select the text file and then import based on your OP.

Code: 
Sub ImportxtFile()


    Dim LineString As String
    Dim sSourceFile As String
    Dim sSepChar As String
    Dim r As Long
    Dim fLen As Long
    Dim fn As Integer
    Dim TypeStr As String
    Dim ModelArr As Variant
    Dim i As Long


    sSourceFile = Application.GetOpenFilename("Text Files (*.txt), *.txt")


    If Len(Dir(sSourceFile)) = 0 Then Exit Sub

    fn = FreeFile


    Open sSourceFile For Input As #fn
    On Error GoTo 0
    fLen = LOF(fn)
    r = 1
    While Not EOF(fn)
        Line Input #fn, LineString
        TypeStr = Left(LineString, InStr(1, LineString, ": ") - 1)
        ModelArr = Split(Replace(LineString, Left(LineString, InStr(1, LineString, ": ") + 1), ""), " ")
        For i = LBound(ModelArr) To UBound(ModelArr)
            Cells(r, 1).Value = TypeStr
            Cells(r, 2).Value = ModelArr(i)
            r = r + 1
        Next i
        r = r + 1
    Wend


    Close #fn
Rows(2).Delete 'to be removed if original file has no headers.
End Sub

I've assumed that your source Text file contains headers if it doesn't remove the last line.

Excel 2010
AB
1TypeModel
2405101
3405103
4405121
5405123
6405201
7405221
8
9900911
10900912
11900913
12900917
13900918
14900919
15900922
16900934
17900936
18900937
19900938

<tbody>
</tbody>
Sheet1​
Click to expand...
Cool.. tho i get a error after import of txt file.
run-time error '5':
Invalid Procedure call or argument

when i hit debug it highlight this Line(RED):
While Not EOF(fn)
Line Input #fn, LineString
TypeStr = Left(LineString, InStr(1, LineString, ": ") - 1)
ModelArr = Split(Replace(LineString, Left(LineString, InStr(1, LineString, ": ") + 1), ""), " ")
For i = LBound(ModelArr) To UBound(ModelArr)
Cells(r, 1).Value = TypeStr
Cells(r, 2).Value = ModelArr(i)
r = r + 1
Next i
r = r + 1
Wend
 
Upvote 0
Based on that Data you sent me try this on a blank worksheet.

You will be asked to select the file for import.

Code: 
Sub TextImport()
Dim txtFile
Dim LastRow As Long
Dim RowLim As Long
Dim DataArr As Variant
Dim ModelArr As Variant
Dim CellColour As Long
Dim i As Long, j As Long, k As Long


txtFile = Application.GetOpenFilename("Text Files (*.txt), *.txt")
i = 2
CellColour = -4142


With ActiveSheet
    .Cells.Clear
    .Cells(1, 1).Value = "Model"
    .Cells(1, 2).Value = "Type"
    With .QueryTables.Add(Connection:= _
        "TEXT;" & txtFile, Destination _
        :=Range("$A$2"))
        .Name = "txtfile"
        .TextFileStartRow = 4
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileTabDelimiter = True
        .TextFileColumnDataTypes = Array(9, 9, 9, 1, 1, 9)
        .Refresh BackgroundQuery:=False
    End With
    .QueryTables(1).Delete
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range("A1:B" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
    .Columns("A:B").Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    DataArr = .Range("A1:B" & LastRow)
    For j = LBound(DataArr) + 1 To UBound(DataArr)
    ModelArr = Split(DataArr(j, 2), " ")
        For k = LBound(ModelArr) To UBound(ModelArr)
            .Cells(i, 1) = DataArr(j, 1)
            .Cells(i, 2) = ModelArr(k)
            .Cells(i, 1).Interior.colorIndex = CellColour
            .Cells(i, 2).Interior.colorIndex = CellColour
            i = i + 1
        Next k
        On Error Resume Next
        If DataArr(j, 1) <> DataArr(j + 1, 1) Then CellColour = Switch(CellColour = 15, -4142, CellColour = -4142, 15)
        On Error GoTo 0
    Next j
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Range("A1:B" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
    .Columns("A:B").Sort key1:=Range("A1"), order1:=xlAscending, key2:=Range("B1"), order2:=xlAscending, Header:=xlYes
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    RowLim = Application.RoundUp(LastRow / 4, 0)
    j = 4
    k = 1
    For i = RowLim To LastRow Step RowLim
        Range(Cells((RowLim * k) + 1, 1), Cells(RowLim * (k + 1), 2)).Cut Cells(1, j)
        j = j + 3
        k = k + 1
    Next i
    End With


End Sub
 
Upvote 0
Comfy said:
Based on that Data you sent me try this on a blank worksheet.

You will be asked to select the file for import.

Code: 
Sub TextImport()
Dim txtFile
Dim LastRow As Long
Dim RowLim As Long
Dim DataArr As Variant
Dim ModelArr As Variant
Dim CellColour As Long
Dim i As Long, j As Long, k As Long


txtFile = Application.GetOpenFilename("Text Files (*.txt), *.txt")
i = 2
CellColour = -4142


With ActiveSheet
    .Cells.Clear
    .Cells(1, 1).Value = "Model"
    .Cells(1, 2).Value = "Type"
    With .QueryTables.Add(Connection:= _
        "TEXT;" & txtFile, Destination _
        :=Range("$A$2"))
        .Name = "txtfile"
        .TextFileStartRow = 4
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileTabDelimiter = True
        .TextFileColumnDataTypes = Array(9, 9, 9, 1, 1, 9)
        .Refresh BackgroundQuery:=False
    End With
    .QueryTables(1).Delete
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range("A1:B" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
    .Columns("A:B").Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    DataArr = .Range("A1:B" & LastRow)
    For j = LBound(DataArr) + 1 To UBound(DataArr)
    ModelArr = Split(DataArr(j, 2), " ")
        For k = LBound(ModelArr) To UBound(ModelArr)
            .Cells(i, 1) = DataArr(j, 1)
            .Cells(i, 2) = ModelArr(k)
            .Cells(i, 1).Interior.colorIndex = CellColour
            .Cells(i, 2).Interior.colorIndex = CellColour
            i = i + 1
        Next k
        On Error Resume Next
        If DataArr(j, 1) <> DataArr(j + 1, 1) Then CellColour = Switch(CellColour = 15, -4142, CellColour = -4142, 15)
        On Error GoTo 0
    Next j
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Range("A1:B" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
    .Columns("A:B").Sort key1:=Range("A1"), order1:=xlAscending, key2:=Range("B1"), order2:=xlAscending, Header:=xlYes
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    RowLim = Application.RoundUp(LastRow / 4, 0)
    j = 4
    k = 1
    For i = RowLim To LastRow Step RowLim
        Range(Cells((RowLim * k) + 1, 1), Cells(RowLim * (k + 1), 2)).Cut Cells(1, j)
        j = j + 3
        k = k + 1
    Next i
    End With


End Sub
Click to expand...

Will do.. Thx. Testing now

WOW thats 99,99% PERFECT!.
only thing missing before print is the resize of the Cell row C F I but can be done i 2 sec so i can totaly live with this! Thx a million!
 
Last edited:
Upvote 0
Comfy said:
Based on that Data you sent me try this on a blank worksheet.

You will be asked to select the file for import.

Code: 
Sub TextImport()
Dim txtFile
Dim LastRow As Long
Dim RowLim As Long
Dim DataArr As Variant
Dim ModelArr As Variant
Dim CellColour As Long
Dim i As Long, j As Long, k As Long


txtFile = Application.GetOpenFilename("Text Files (*.txt), *.txt")
i = 2
CellColour = -4142


With ActiveSheet
    .Cells.Clear
    .Cells(1, 1).Value = "Model"
    .Cells(1, 2).Value = "Type"
    With .QueryTables.Add(Connection:= _
        "TEXT;" & txtFile, Destination _
        :=Range("$A$2"))
        .Name = "txtfile"
        .TextFileStartRow = 4
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileTabDelimiter = True
        .TextFileColumnDataTypes = Array(9, 9, 9, 1, 1, 9)
        .Refresh BackgroundQuery:=False
    End With
    .QueryTables(1).Delete
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range("A1:B" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
    .Columns("A:B").Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    DataArr = .Range("A1:B" & LastRow)
    For j = LBound(DataArr) + 1 To UBound(DataArr)
    ModelArr = Split(DataArr(j, 2), " ")
        For k = LBound(ModelArr) To UBound(ModelArr)
            .Cells(i, 1) = DataArr(j, 1)
            .Cells(i, 2) = ModelArr(k)
            .Cells(i, 1).Interior.colorIndex = CellColour
            .Cells(i, 2).Interior.colorIndex = CellColour
            i = i + 1
        Next k
        On Error Resume Next
        If DataArr(j, 1) <> DataArr(j + 1, 1) Then CellColour = Switch(CellColour = 15, -4142, CellColour = -4142, 15)
        On Error GoTo 0
    Next j
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Range("A1:B" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
    .Columns("A:B").Sort key1:=Range("A1"), order1:=xlAscending, key2:=Range("B1"), order2:=xlAscending, Header:=xlYes
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    RowLim = Application.RoundUp(LastRow / 4, 0)
    j = 4
    k = 1
    For i = RowLim To LastRow Step RowLim
        Range(Cells((RowLim * k) + 1, 1), Cells(RowLim * (k + 1), 2)).Cut Cells(1, j)
        j = j + 3
        k = k + 1
    Next i
    End With


End Sub
Click to expand...

Add to my last Reply.
Where in the code do i set how far in the letters it can go. just for optimising i want ti to go end with (including) P Q
 
Upvote 0
Change:

Code: 
RowLim = Application.RoundUp(LastRow / 4, 0)

to

RowLim = Application.RoundUp(LastRow / 6, 0)

Additionally add this at the end of the code before the last End With

Code: 
.Columns("C:C").ColumnWidth = 1
.Columns("F:F").ColumnWidth = 1
.Columns("I:I").ColumnWidth = 1
.Columns("L:L").ColumnWidth = 1
.Columns("O:O").ColumnWidth = 1
 
Last edited:
Upvote 0
Comfy said:
Change:

Code: 
RowLim = Application.RoundUp(LastRow / 4, 0)

to

RowLim = Application.RoundUp(LastRow / 6, 0)

Additionally add this at the end of the code before the last End With

Code: 
.Columns("C:C").ColumnWidth = 1
.Columns("F:F").ColumnWidth = 1
.Columns("I:I").ColumnWidth = 1
.Columns("L:L").ColumnWidth = 1
.Columns("O:O").ColumnWidth = 1
Click to expand...

Awsome.. i addet some more columns width on the others to the right size witch works perfect :)

tho i for got to tell 1 thing. i need for the sheet to be in txt or be able to show numbers if 3 all the time.
like 500, 050, 005, 000

how do it determen how long to be in the code? jsut trying to lean a bit of it :)
 
Upvote 0
One way would be to add some lines here:

Code: 
For k = LBound(ModelArr) To UBound(ModelArr)
.Cells(i, 1) = DataArr(j, 1)
.Cells(i, 2) = ModelArr(k)
.Cells(i, 1).Interior.colorIndex = CellColour
.Cells(i, 2).Interior.colorIndex = CellColour
.Cells(i, 1).NumberFormat = "000"
.Cells(i, 2).NumberFormat = "000"

i = i + 1
Next k
 
Upvote 0
ZaXaZ,

Thanks for the new workbook.

I assume that your raw data worksheet is the first worksheet on the left in the sheets view.

After the macro in a new worksheet Results (not all rows, and, columns are shown to fit the MrExcel display area):


Excel 2007
ABCDEFYZAAABACAD
1ModelType355916935952936973
2100981355918936971936973
3100983355918936971
4159980355960936971
5177980355961936971
6177980355962936971
7178980355963936971
8203081355964936980
9203084355966936980
10203087355967936980
41355911389018936972
42355912389019936972
43355912389022936972
44355913389023936972
45355913389024936972
46355914389026936972
47355914389027936973
48355915389034936973
49355915389043936973
50355916389044936973
51
Results


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).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code: 
Sub ReorgDataV2()
' hiker95, 02/24/2015, ME837837
Dim w1 As Worksheet, wr As Worksheet
Dim r As Long, lr As Long, c As Range, s, i As Long, nr As Long, nlr As Long, nc As Long
Application.ScreenUpdating = False
Set w1 = Sheets(1)
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Sheets("Results")
wr.UsedRange.Clear
wr.Cells(1, 1).Resize(, 2).Value = Array("Model", "Type")
With w1
  .Activate
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  With .Range("A2:B" & lr)
    .Value = Evaluate("IF(ISTEXT(" & .Address & "),TRIM(" & .Address & "),REPT(" & .Address & ",1))")
  End With
  For Each c In .Range("B2:B" & lr)
    nr = wr.Cells(.Rows.Count, "A").End(xlUp).Row + 1
    If InStr(c, " ") Then
      s = Split(c, " ")
      wr.Cells(nr, 1).Resize(UBound(s) + 1, 2).NumberFormat = "@"
      wr.Cells(nr, 2).Resize(UBound(s) + 1) = Application.Transpose(s)
      wr.Cells(nr, 1).Resize(UBound(s) + 1) = c.Offset(, -1).Value
    Else
      c.Offset(, -1).Resize(, 2).Copy wr.Cells(nr, 1)
    End If
    Application.CutCopyMode = False
  Next c
End With
With wr
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  .Range("A2:B" & lr).Sort key1:=.Range("A2"), order1:=1, key2:=.Range("B2"), order2:=1
  nlr = Application.Ceiling(lr, 50)
  nc = 4
  For r = 51 To nlr Step 50
    .Range("A" & r & ":B" & r + 49).Copy .Cells(1, nc)
    Application.CutCopyMode = False
    nc = nc + 3
  Next r
  .Range("A51:B" & nlr).ClearContents
  .Columns.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, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgDataV2 macro.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
average based on time
Replies
1
Views
306
baqer
B
J
  • Question
Excel macro for Remove comma's and spaces from a cell and place the data in different cell
Replies
3
Views
975
JEC
JEC
J
  • Question
Need some help with permutation code, convert from one cell to a range
Replies
3
Views
298
johnnyL
J
A
  • Solved
transpose data int listbox on userform based on two dates or without dates
Replies
2
Views
191
Alaa mg
A
M
  • Question
first derivative
Replies
3
Views
725
JamesCanale
JamesCanale

Forum statistics

Threads
1,216,350
Messages
6,130,139
Members
449,560
Latest member
mattstan2012

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top