![]() |
|
#1
|
|||
|
|||
|
Dear Forum,
I am a novice creating macros. I would like to refine my macro as it is too long and I am sure it can be much better. The macro should: 1) convert a csv document to excel 2) insert two columns one for a date format and another for a number of rows 3) to delete the empty rows 4) the rows vary, how can I define it better, sometimes is only up to row 30, sometimes to row 60, etc... example file, (the real file has many columns and rows): Date,"Name" 20151231,"ate at restaurant" 20151231,"bought something" My macro is like this: Sub ConvertToTable() ' 'convert text to table ' Range("A:A").Select Selection.Copy ExecuteExcel4Macro "WINDOW.SIZE(398,53,"""")" ExecuteExcel4Macro "WINDOW.MOVE(2,-43,"""")" Workbooks.Add ActiveSheet.Paste Application.CutCopyMode = False Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :="""", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 9), Array(4, 1), Array(5 _ , 9), Array(6, 1), Array(7, 9), Array(8, 1), Array(9, 9), Array(10, 1), Array(11, 9), Array( _ 12, 1), Array(13, 9), Array(14, 1), Array(15, 9), Array(16, 1), Array(17, 1)) Range("A2").Select Selection.EntireColumn.Insert Selection.EntireColumn.Insert ' add to columns date Range("B1").Select ActiveCell.FormulaR1C1 = "Date2" Range("B2").Select ActiveWindow.SmallScroll ToRight:=6 ActiveCell.FormulaR1C1 = _ "=IF(RC[1]<>"""",(DATE(LEFT(RC[1],4),VALUE(MID(RC[1],5,2)),RIGHT(RC[1],2))),"" "")" Range("B2").Select Selection.NumberFormat = "dd-mmm-yy" Selection.AutoFill Destination:=Range("B2:B100") Range("B1:B100").Select ActiveWindow.LargeScroll Down:=1 Range("B1:B100").Select ActiveWorkbook.Worksheets("Blad1").Sort.SortFields .Clear ActiveWorkbook.Worksheets("Blad1").Sort.SortFields .Add Key:=Range("B1"), _ SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Blad1").Sort .SetRange Range("B2:K100") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ' sort by date Range("B1:M107").Select ActiveWindow.ScrollRow = 1 ActiveWorkbook.Worksheets("Blad1").Sort.SortFields .Clear ActiveWorkbook.Worksheets("Blad1").Sort.SortFields .Add Key:=Range("B1"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Blad1").Sort .SetRange Range("B2:L100") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ' add to columns number from 1 forward Range("A1").Select ActiveCell.FormulaR1C1 = "no" Range("A2").Select ActiveCell.FormulaR1C1 = "1" Range("A3").Select ActiveCell.FormulaR1C1 = "2" Range("A3").Select ActiveCell.FormulaR1C1 = "=R[-1]C+1" Range("A3").Select Selection.AutoFill Destination:=Range("A3:A100") Range("A3:A61").Select ActiveWindow.SmallScroll Down:=-63 Range("A2").Select 'delete empy rows On Error Resume Next Application.ScreenUpdating = False Columns("D ").SpecialCells(xlCellTypeBlanks).Enti reRow.DeleteApplication.ScreenUpdating = True End Sub Thanks for your help. Coba |
|
#2
|
|||
|
|||
|
Dear CB-expert,
I would really appreciate feedback
|
|
#3
|
||||
|
||||
|
Perhaps this:
Code:
Sub ConvertToTable()
'
'convert text to table
'
Dim LastRow As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
Range("A:A").Copy
Workbooks.Add
Set ws = ActiveSheet
With ws
.Paste
Application.CutCopyMode = False
Selection.TextToColumns Destination:=ws.Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="""", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 9), Array(4, 1), Array(5, 9), _
Array(6, 1), Array(7, 9), Array(8, 1), Array(9, 9), Array(10, 1), Array(11, 9), _
Array(12, 1), Array(13, 9), Array(14, 1), Array(15, 9), Array(16, 1), Array(17, 1))
.Range("A:B").EntireColumn.Insert
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
' add to columns date
.Range("B1").Value2 = "Date2"
With .Range("B2:B" & LastRow)
.FormulaR1C1 = "=IF(RC[1]<>"""",TEXT(RC[1],""0000-00-00"")+0,"""")"
.NumberFormat = "dd-mmm-yy"
End With
With .Sort
With .SortFields
.Clear
.Add Key:=ws.Range("B1"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
End With
.SetRange ws.Range("B2:L100")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' add to columns number from 1 forward
.Range("A1").Value2 = "no"
With .Range("A2")
.Value2 = 1
.AutoFill Destination:=ws.Range("A2:A" & LastRow), Type:=xlFillSeries
End With
'delete empty rows
On Error Resume Next
.Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End With
End Sub
|
|
#4
|
|||
|
|||
|
Thank you very much.
It looks more professional now coba Last edited by coba; 01-07-2016 at 04:23 AM. Reason: Solved |
|
| Tags |
| convert text to column, excel-vba |
| Thread Tools | |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Thread Starter | Forum | Replies | Last Post |
Convert text to date format
|
klllmmm | Excel | 5 | 11-16-2015 07:02 AM |
| Letter date changes when merging with Excel - not the format, the actual date! | Smallweed | Mail Merge | 1 | 02-07-2014 06:00 PM |
Document properties in word - date format
|
Chieps | Word | 8 | 09-26-2013 11:37 PM |
| Excel formula from looking the base date and convert into desire result | PRADEEPB270 | Excel | 1 | 02-17-2013 03:11 AM |
Excel convert format [h]:mm:ss to decimal
|
gchan2000 | Excel | 1 | 08-17-2010 01:36 PM |