Export table data to excel

[Gasman]

And the error is?

 

[suryu]

And the error is?

it is not getting executed debug issue

 

[Gasman]

Damn, this is hard work.

I cannot see you even have assigned anything to wb ?

Does the code even compile?

Try this way?

https://stackoverflow.com/questions/35160792/add-sheet-to-excel-through-access-vba

 

[arnelgp]

try this:


wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count)).Name = "Order"

 

[suryu]

try this:


wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count)).Name = "Order"

Hi arnelgp,
Thanks a lot , I have used your code its working fine now

 

[suryu]

Damn, this is hard work.

I cannot see you even have assigned anything to wb ?

Does the code even compile?

Try this way?

https://stackoverflow.com/questions/35160792/add-sheet-to-excel-through-access-vba

Thank you

 

[suryu]

Hi @arnelgp,
Hope you are doing good

i have one doubt

i want to split id value present in one row to columnwise data see below for details

>> If in excel B2 value is 10001;10002;10003
it should give value column wise in C2, D2,E2 delimited ; i.e, 10001,10002,10003 using vba

i am trying to do like below code

splitstring=thisworkbook.sheets("sheet1").cells(1,2).value

myarray=split(splitstring,";")

for i=0 to UBound(myarray)

?
next

confused whether to take for loop or while because delimiter ; can b more than 3,4

kindly do suugest

thank you

 

[arnelgp]

rename Sheet1 in the code with your sheet name

Dim r As Range
Dim rValue As String
Dim vValue As Variant
Dim v As Variant
Dim i As Integer
Dim cValue As New Collection
Set r = Sheet1.Range("b2")
rValue = r.Value
If r Like "*;*" Then
    vValue = Split(rValue, ";")
    For Each v In vValue
        If Trim(v & "") <> "" Then
            cValue.Add v & ""
        End If
    Next
End If
For i = 1 To cValue.Count
    r.Offset(0, i).Value = cValue.Item(i)
Next
Set cValue = Nothing
Erase vValue

 

[suryu]

Hi @arnelgp
Above code is fine but i want to do for the particular column till last row

>> Data is given in the below format

Customer	Collateral Id	Status
Ramesh	008023378 ; 011123884 ; 0092346-9734;
Suresh	;102333345
Mohan	#

>> I need data in below format

Customer	Collateral Id	Collateral Id1	Collateral Id2	Status
Ramesh	008023378 ;	011123884 ;	0092346-9734;
Suresh	;102333345
Mohan	0

>>please find the below code i have done it is giving data seperated by delimiter.
>>facing issues how to rename column header after seperation

Private Sub CommandButton1_Click()

Dim a As Integer
Dim i As Integer
Dim LastRow As Integer
Dim SplitString As String
Dim myarray() As String

LastRow = Range("B" & Rows.Count).End(xlUp).Row

For a = 2 To LastRow
SplitString = ThisWorkbook.Sheets("Sheet1").Cells(a, 2).Value
myarray = Split(SplitString, ";")

For i = 0 To UBound(myarray)
ThisWorkbook.Sheets("Sheet1").Cells(a, i + 2).Value = myarray(i)
Next

Next


End Sub

 

[arnelgp]

Dim sh As Worksheet
Dim r As Range
Dim last_row As Long
Dim column_header As String
Dim c As New Collection
Dim m As New Collection
Dim i As Long, j As Long, k As Long
Dim max_column As Byte
Dim n As Byte
Dim v As Variant

Set sh = Sheet1
Set r = sh.Range("b1")
column_header = r.Value

last_row = sh.Range("A" & Rows.Count).End(xlUp).Row
'save ids to collection and at the same time
'determine the max column to make
For i = 2 To last_row
    n = delim_count(sh.Range("b" & i).Value & "")
    If n > max_column Then
        max_column = n
    End If
    c.Add sh.Range("b" & i).Value & ""
Next
'insert the column
Call insert_column(sh.Range("c:c"), max_column - 1)
'put the title
For i = 1 To max_column - 1
    r.Offset(0, i).Value = column_header & i
Next
'remove blank item from collection
'and put the ids
For i = 1 To c.Count
    v = Split(c.Item(i), ";")
    For j = 0 To UBound(v)
        If Trim(v(j)) <> "" Then
            m.Add Replace(Trim(v(j)), ";", "")
        End If
    Next
    For j = 0 To m.Count - 1
        r.Offset(i, j) = m.Item(j + 1)
    Next
    Set m = New Collection
Next
Set c = Nothing
Set m = Nothing
Erase v

End Sub

Public Function delim_count(ByVal s As String, Optional d As String = ";") As Byte
Dim n_pos As Integer, n As Byte
n_pos = InStr(1, s, d)
While n_pos > 0
    n = n + 1
    n_pos = InStr(n_pos + 1, s, d)
Wend
delim_count = n
End Function


Public Function insert_column(r As Range, Optional num_to_insert As Byte = 1)
    Dim i As Byte
    For i = 1 To num_to_insert
        r.Select
        Application.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Next
End Function

 

[suryu]

Dim sh As Worksheet
Dim r As Range
Dim last_row As Long
Dim column_header As String
Dim c As New Collection
Dim m As New Collection
Dim i As Long, j As Long, k As Long
Dim max_column As Byte
Dim n As Byte
Dim v As Variant

Set sh = Sheet1
Set r = sh.Range("b1")
column_header = r.Value

last_row = sh.Range("A" & Rows.Count).End(xlUp).Row
'save ids to collection and at the same time
'determine the max column to make
For i = 2 To last_row
    n = delim_count(sh.Range("b" & i).Value & "")
    If n > max_column Then
        max_column = n
    End If
    c.Add sh.Range("b" & i).Value & ""
Next
'insert the column
Call insert_column(sh.Range("c:c"), max_column - 1)
'put the title
For i = 1 To max_column - 1
    r.Offset(0, i).Value = column_header & i
Next
'remove blank item from collection
'and put the ids
For i = 1 To c.Count
    v = Split(c.Item(i), ";")
    For j = 0 To UBound(v)
        If Trim(v(j)) <> "" Then
            m.Add Replace(Trim(v(j)), ";", "")
        End If
    Next
    For j = 0 To m.Count - 1
        r.Offset(i, j) = m.Item(j + 1)
    Next
    Set m = New Collection
Next
Set c = Nothing
Set m = Nothing
Erase v

End Sub

Public Function delim_count(ByVal s As String, Optional d As String = ";") As Byte
Dim n_pos As Integer, n As Byte
n_pos = InStr(1, s, d)
While n_pos > 0
    n = n + 1
    n_pos = InStr(n_pos + 1, s, d)
Wend
delim_count = n
End Function


Public Function insert_column(r As Range, Optional num_to_insert As Byte = 1)
    Dim i As Byte
    For i = 1 To num_to_insert
        r.Select
        Application.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Next
End Function

Thank you so much its working fine