it is not getting executed debug issueAnd the error is?
Hi arnelgp,try this:
wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count)).Name = "Order"
Thank youDamn, 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
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
Customer | Collateral Id | Status |
Ramesh | 008023378 ; 011123884 ; 0092346-9734; | |
Suresh | ;102333345 | |
Mohan | # |
Customer | Collateral Id | Collateral Id1 | Collateral Id2 | Status |
Ramesh | 008023378 ; | 011123884 ; | 0092346-9734; | |
Suresh | ;102333345 | |||
Mohan | 0 |
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 fineCode: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