TextToColumns in shared workbook..

[conradcliff]

Hey guys, I want to start off by saying thank you to all those that do so much to help. I honestly feel bad that I don't have the time/knowledge to browse around the forum and try and help others as I have been helped...I'm wondering right now if there is a way to donate to the forum..I'll check that out right after I write this post.

Anyway, I have a macro that uses TextToColumns to separate data that is pasted into one cell and spread it out into multiple cells in a column.
It works great until I share the workbook; at which point I get:

Run-time error '1004': TextToColumns method of Range class failed

Here is the code...it's pretty messy :-/

Sub Direct_Paste2()
'
' Direct_Paste2 Macro

    Range("DirectPasteCell1").Select
    
    ActiveSheet.Paste
    
    Range("DirectPasteCell1").Select
    
   '  Dim cel As Range
   ' For Each cel In ActiveSheet.UsedRange
   '     cel = Replace(cel, Chr(10), " ")
   ' Next
    
    Range("DirectPasteCell1").Replace What:=vbCrLf, Replacement:=vbKeySpace
    
    Range("DirectPasteCell1").Select
    Range("DirectPasteCell1").TextToColumns Destination:=Range("DirectPasteCell1"), DataType:=xlDelimited _
        , TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array( _
        25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), _
        Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array( _
        38, 1), Array(39, 1), Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), _
        Array(45, 1), Array(46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array( _
        51, 1), Array(52, 1), Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1)), TrailingMinusNumbers _
        :=True
    Range("DirectPasteTodaysDate") = "=TODAY()"
    Range("DirectPasteCDs") = "1"
    Range("DirectPasteRange").Select
    Selection.Copy
    Sheets("InvoiceMaster").Activate
            Range("B228").Select
            For B = 228 To 65536
        If ActiveCell.Value = Empty Then
            BCell = "B" & CStr(B - 1)
            NBCell = "B" & CStr(B - 2)
        Else
            Range("B" & CStr(B + 0)).Select
End If
    Next B
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
        
    ActiveCell.Offset(0, 3).Select
    If ActiveCell.Value = ": " Then
    ActiveCell.Value = ""
End If
        
    ActiveCell.Offset(0, 53).Select
    If ActiveCell.Value = ""specified value"" Then
    ActiveCell.Value = ""
End If

    Dim DataObj As New MSForms.DataObject
    Dim AddressString As String
    AddressString = ""
    Range(ActiveCell.Offset(0, -22), ActiveCell.Offset(0, -26)).Select
    For Each Cell In Selection
    AddressString = AddressString & Cell.Value & " "
  Next Cell
    
    DataObj.SetText AddressString
    DataObj.PutInClipboard

    
    ActiveWorkbook.FollowHyperlink address:="http://maps.google.com"
    
    ActiveCell.Offset(0, 4).Select
    
    Range("DirectPasteRange").ClearContents
    
    ActiveWorkbook.Save
    
   
End Sub

I've done quite a bit of searching on google but couldn't seem to come up with anything. I did run across one post on a microsoft forum or something that seemed to suggest that the TextToColumns feature was disabled for shared workbooks in excel 2007 and 2010..not sure about that though.

Anyway, if anyone could help I would be really appreciative.

Thank again!

 

[conradcliff]

Hey guys, just wondering if anyone had any ideas about this still..

I cleaned up the code quite a bit since the last time
Here's what I have now:

Sub Direct_Paste()


Dim DataObj As New MSForms.DataObject
Dim DirectPasteData, AddressString, EventNameString As String
    DataObj.GetFromClipboard
    DirectPasteData = DataObj.GetText
    DirectPasteData = Replace(DirectPasteData, vbCr, " ")
    DirectPasteData = Replace(DirectPasteData, vbLf, " ")
    
    Range("DirectPasteCell1") = DirectPasteData
  
    Range("DirectPasteCell1").TextToColumns Destination:=Range("DirectPasteCell1"), DataType:=xlDelimited _
        , TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array( _
        25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), _
        Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array( _
        38, 1), Array(39, 1), Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), _
        Array(45, 1), Array(46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array( _
        51, 1), Array(52, 1), Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1)), TrailingMinusNumbers _
        :=True
    Range("DirectPasteTodaysDate") = "=TODAY()"
    Range("DirectPasteCDs") = "1"
    Range("DirectPasteRange").Copy
    Sheets("InvoiceMaster").Activate
            Range("B335").Select
            For B = 335 To 65536
        If ActiveCell.Value = Empty Then
            BCell = "B" & CStr(B - 1)
            NBCell = "B" & CStr(B - 2)
        Else
            Range("B" & CStr(B + 0)).Select
End If
    Next B
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    
    If ActiveCell.Offset(0, 3).Value = ": " Then
    ActiveCell.Offset(0, 3).Value = ""
End If
    
    If ActiveCell.Offset(0, 27).Value = "http://www.snapshootphotobooth.com/formtools/upload/" Then
    ActiveCell.Offset(0, 27).Value = ""
End If
    
    EventNameString = ActiveCell.Offset(0, 28)
    EventNameString = Replace(EventNameString, "/", " ")
    EventNameString = Replace(EventNameString, "\", " ")
    EventNameString = Replace(EventNameString, ":", " ")
    EventNameString = Replace(EventNameString, "*", " ")
    EventNameString = Replace(EventNameString, "?", " ")
    EventNameString = Replace(EventNameString, Chr(34), " ")
    EventNameString = Replace(EventNameString, "<", " ")
    EventNameString = Replace(EventNameString, ">", " ")
    EventNameString = Trim(EventNameString)
    ActiveCell.Offset(0, 28).Value = EventNameString

    If ActiveCell.Offset(0, 57).Value = "http://www.snapshootphotobooth.com/formtools/upload/" Then
    ActiveCell.Offset(0, 57).Value = ""
End If

    Set DataObj = New DataObject
    With Range(ActiveCell.Offset(0, 30), ActiveCell.Offset(0, 33))
        DataObj.SetText .Cells(1).Text & " " & .Cells(2).Text & " " & .Cells(3).Text & " " & .Cells(4).Text
    End With
    DataObj.PutInClipboard
    
    

    
    ActiveWorkbook.FollowHyperlink address:="http://maps.google.com"
    
    ActiveCell.Offset(0, 34).Select
    
    Range("DirectPasteRange").ClearContents
    
    ActiveWorkbook.Save
    
End Sub

If anyone has any idea why it wont operate when the workbook is shared I would really appreciate it.

Thanks again!!