jana
asked on
How to unWrap when exporting in VBA Excel
We have a VBA routine that exports email but it keeps exporting it with "wrap" setup. How can we include a code when exporting or "writing" to an excel file (current code lines used below):
What do you mean by "wrap" setup?
ASKER
Hi!
We mean by "wrap" is when a cell content is longer than the cell it would "wrap" the content thus making the cell open up and display its entire content.
The problem we have is that when running the routine it always "wrap" all columns and we want to to be written "unwrap".
We mean by "wrap" is when a cell content is longer than the cell it would "wrap" the content thus making the cell open up and display its entire content.
The problem we have is that when running the routine it always "wrap" all columns and we want to to be written "unwrap".
You will have to set the width manually.
You can do so by adding this code after you dump your data into Excel:
You can do so by adding this code after you dump your data into Excel:
Range("B1:F1").ColumnWidth = Range("XFD1").ColumnWidth
Try:
xlSheet.Range("B1:F1").ColumnWidth = Range("XFD1").ColumnWidth
ASKER
nope
ASKER
same err
Can you show me the entire code?
Which version of Excel are you using?
Which version of Excel are you using?
ASKER
excel 2010
ASKER
here it is":
ASKER
code:
Sub aaaCopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColB, strColC, strColD, strColE, strColF As String
'Start
xVar = 0
'Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\test.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process the message record
On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
'Get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'Get Outlook fields
strColB = olItem.SenderEmailAddress
strColC = olItem.To
strColD = olItem.Subject
strColE = olItem.ReceivedTime
strColF = olItem.Body
'Write Outlook field to excel
xlSheet.Range("B" & rCount) = strColB 'SenderEmailAddress
xlSheet.Range("c" & rCount) = strColC 'To
xlSheet.Range("d" & rCount) = strColD 'Subject
xlSheet.Range("e" & rCount) = strColE 'ReceivedTime
xlSheet.Range("f" & rCount) = strColF 'Body
xVar = xVar + 1
Next
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Here:
Sub aaaCopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColB, strColC, strColD, strColE, strColF As String
'Start
xVar = 0
'Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\test.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process the message record
On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
'Get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'Get Outlook fields
strColB = olItem.SenderEmailAddress
strColC = olItem.To
strColD = olItem.Subject
strColE = olItem.ReceivedTime
strColF = olItem.Body
'Write Outlook field to excel
xlSheet.Range("B" & rCount) = strColB 'SenderEmailAddress
xlSheet.Range("c" & rCount) = strColC 'To
xlSheet.Range("d" & rCount) = strColD 'Subject
xlSheet.Range("e" & rCount) = strColE 'ReceivedTime
xlSheet.Range("f" & rCount) = strColF 'Body
xVar = xVar + 1
Next
xlSheet.Range("B1:F1").ColumnWidth = Range("ABC1").ColumnWidth
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Hi Macro, kept getting the error...
Subodh, worked perfectly!!!! Thanx!!!
Subodh, worked perfectly!!!! Thanx!!!
You're welcome. Glad to help.
ASKER
Open in new window