Please could you help me understand how access imports from Excel
I am using linked files to Excel
I have 8 Excel spreadsheets which I import from our maintenance system
I have 3 limits in each of the spreadsheets
Limit 1, Limit 2 and Limit 3, each with a unit of measure
In my limit 2 column (for example) I have a combination of 2 different months in some of the rows, it will show as below
when you click on wrap text, below is what you see
when imported, you only see the
when running queries or display in a form or report
how do i import with this in 2 different records
basically, how do i link to excel to show individual records when a line was wrapped in Excel
Save the 8 workbooks to the same name everytime: c:\temp\file2import1.xlsx,
File2import2.xlsx...
Link the 8 sheets as linked external tables.
Make an append query for each,along with the criteria to limit what imports.
Put them all queries in a macro.
Then the steps are:
1. Save all workbooks
2. Run macro
Done.
don't believe you can since the 'wrap' is dictated by the column width.
It may be the user when inputting has used a CR and/or LF characters to create a second line (limit2). If this is the case you would need code to split the text on this/these characters and insert each element into different records (see the vba split function). If they haven't then you don't have much to go on - perhaps compare the column width to font size to work out how many characters can appear on one line - google Stephen Lebans for code that you might be able to adapt - look for the autoresize code which sizes a textbox to the text, you would need a reverse procedure of some sort. Or perhaps your unit2 only has a single character per line so you can simply use the len function to determine how many records you need to create.
Either way, will require some fairly complex vba to do what you want
do you have sample xlxs/xls that we can look at?
are there Merrged cells?
i made a function (just for you) to Unmerged the cells.
note: you need to add Reference to Microsoft Excel X.XX Object.
I have not yet converted it to Late binding:
Code:
Option Compare Database
Option Explicit
Public Sub UnmergeCellsInWB(ByVal WB As String)
Dim oWB As Excel.Workbook
Dim oSH As Excel.Worksheet
Dim rng As Excel.Range
Dim r As Excel.Range
Dim allrng As Excel.Range
Dim i As Integer, j As Integer
Dim c_parent As New Collection
Dim c_child As Collection
Dim c_merged As New Collection
Dim c_temp As Collection
Dim theValue As Variant
'exit if invalid filename
If Len(Dir$(WB)) < 1 Then
Exit Sub
End If
'no validation if the workbook is password protected.
Set oWB = XlApp.Workbooks.Open(WB)
For Each oSH In oWB.Worksheets
Set allrng = oSH.UsedRange
For Each rng In allrng
If IsMerged(rng) Then
i = 1
c_merged.Add rng.MergeArea.Address
Set c_child = New Collection
'Debug.Print rng.MergeArea.Address
For Each r In rng.MergeArea
'Debug.Print i, r.Address
'i = i + 1
c_child.Add r.Address
Next
c_parent.Add c_child
End If
DoEvents
Next
'unmerge the cells
For i = 1 To c_merged.Count
Call UnmergeCells(oSH.Range(c_merged(i)))
Next
'copy first cell of merged cells to the
'rest of cells
For i = 1 To c_parent.Count
Set c_temp = c_parent(i)
For j = 1 To c_temp.Count
If j = 1 Then
theValue = oSH.Range(c_temp(j)).Value
Else
oSH.Range(c_temp(j)).Value = theValue
End If
Next
Next
Next
Set oSH = Nothing
oWB.Close True
Set oWB = Nothing
Set allrng = Nothing
Set rng = Nothing
Set c_parent = Nothing
Set c_child = Nothing
Set c_merged = Nothing
Set c_temp = Nothing
End Sub
Public Function XlApp() As Excel.Application
Static xl As Excel.Application
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set XlApp = xl
End Function
'https://stackoverflow.com/questions/14599841/how-to-get-find-if-a-cell-in-excel-is-merged-if-the-cell-mrged-how-to-read-the
Function IsMerged(rCell As Range) As Boolean
' Returns true if referenced cell is Merged
IsMerged = rCell.MergeCells
End Function
'https://www.automateexcel.com/vba/merge-cells/
Sub UnmergeCells(ByRef rng As Range)
rng.UnMerge
End Sub
how can I check how the data was entered or assembled
i believe it has been wrapped by a new line / enter
how do I test for this?
i dont have spit as a function in my Access function
do you have sample xlxs/xls that we can look at?
are there Merrged cells?
i made a function (just for you) to Unmerged the cells.
note: you need to add Reference to Microsoft Excel X.XX Object.
I have not yet converted it to Late binding:
Code:
Option Compare Database
Option Explicit
Public Sub UnmergeCellsInWB(ByVal WB As String)
Dim oWB As Excel.Workbook
Dim oSH As Excel.Worksheet
Dim rng As Excel.Range
Dim r As Excel.Range
Dim allrng As Excel.Range
Dim i As Integer, j As Integer
Dim c_parent As New Collection
Dim c_child As Collection
Dim c_merged As New Collection
Dim c_temp As Collection
Dim theValue As Variant
'exit if invalid filename
If Len(Dir$(WB)) < 1 Then
Exit Sub
End If
'no validation if the workbook is password protected.
Set oWB = XlApp.Workbooks.Open(WB)
For Each oSH In oWB.Worksheets
Set allrng = oSH.UsedRange
For Each rng In allrng
If IsMerged(rng) Then
i = 1
c_merged.Add rng.MergeArea.Address
Set c_child = New Collection
'Debug.Print rng.MergeArea.Address
For Each r In rng.MergeArea
'Debug.Print i, r.Address
'i = i + 1
c_child.Add r.Address
Next
c_parent.Add c_child
End If
DoEvents
Next
'unmerge the cells
For i = 1 To c_merged.Count
Call UnmergeCells(oSH.Range(c_merged(i)))
Next
'copy first cell of merged cells to the
'rest of cells
For i = 1 To c_parent.Count
Set c_temp = c_parent(i)
For j = 1 To c_temp.Count
If j = 1 Then
theValue = oSH.Range(c_temp(j)).Value
Else
oSH.Range(c_temp(j)).Value = theValue
End If
Next
Next
Next
Set oSH = Nothing
oWB.Close True
Set oWB = Nothing
Set allrng = Nothing
Set rng = Nothing
Set c_parent = Nothing
Set c_child = Nothing
Set c_merged = Nothing
Set c_temp = Nothing
End Sub
Public Function XlApp() As Excel.Application
Static xl As Excel.Application
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set XlApp = xl
End Function
'https://stackoverflow.com/questions/14599841/how-to-get-find-if-a-cell-in-excel-is-merged-if-the-cell-mrged-how-to-read-the
Function IsMerged(rCell As Range) As Boolean
' Returns true if referenced cell is Merged
IsMerged = rCell.MergeCells
End Function
'https://www.automateexcel.com/vba/merge-cells/
Sub UnmergeCells(ByRef rng As Range)
rng.UnMerge
End Sub
I found a non printable character and then CHR(10) ?
Code:
Sub PrintChar()
Dim i As Integer
For i = 1 To Len(ActiveCell.Value)
Debug.Print Mid(ActiveCell.Value, i, 1) & " " & Asc(Mid(ActiveCell.Value, i, 1))
Next
End Sub
ok, this will Create new row and Split those values that has Chr(10) on them.
if there is 1 Chr(10) on the cell, it add another row of same data.
if there are 2 it will create addional 2 rows.
before importing the excel workbook.
call the function ExpandChar10(), passing the fullpath+name of the excel to import.
'arnelgp
Public Sub ExpandChar10(ByVal WB As String)
'early binding
'Dim oWB As Excel.Workbook
'Dim oSH As Excel.Worksheet
'Dim rng As Excel.Range
'Dim r As Excel.Range
On Error GoTo err_handler
'late binding
Dim oWB As Object
Dim oSH As Object
Dim rng As Object
Dim r As Object
'Dim allrng As Excel.Range
Dim allrng As Object
Dim i As Integer, j As Integer, k As Integer
Dim c_cells As Collection
Dim c_rows As Collection
Dim theValue As Variant
Dim aValues As Variant
'exit if invalid filename
If Len(Dir$(WB)) < 1 Then
Exit Sub
End If
'no validation if the workbook is password protected.
Set oWB = XlApp.Workbooks.Open(WB)
For Each oSH In oWB.Worksheets
Set c_cells = New Collection
Set allrng = oSH.UsedRange
For Each rng In allrng
theValue = rng.Value & vbNullString
If theValue Like "*" & Chr(10) & "*" Then
c_cells.Add rng.Address
End If
Next
Set c_rows = New Collection
For i = 1 To c_cells.Count
'Debug.Print oSH.Name & " " & c_cells(i)
'add the rows to collection
On Error Resume Next
c_rows.Add CLng(Mid$(c_cells(i), InStrRev(c_cells(i), "$") + 1)), Mid$(c_cells(i), InStrRev(c_cells(i), "$") + 1)
On Error GoTo err_handler
Next
'sort c_cells Descending
If c_rows.Count <> 0 Then
Call SortCollectionAsc(c_rows)
End If
For i = c_rows.Count To 1 Step -1
'copy the rows and remove the chr(10)
oSH.Rows(c_rows(i) & ":" & c_rows(i)).Select
XlApp.Selection.Copy
XlApp.Selection.Insert Shift:=-4121 'xlDown
'split the values with chr(10)
For j = 1 To c_cells.Count
If c_cells(j) Like ("*$" & c_rows(i)) Then
aValues = Split(oSH.Range(c_cells(j)).Value, Chr(10))
For k = 0 To UBound(aValues)
oSH.Range(c_cells(j)).Offset(k, 0).Value = removeUnwatedChars(aValues(k))
Next k
End If
Next j
Next i
Next
Set oSH = Nothing
oWB.Close True
resume_here:
Set oWB = Nothing
Set allrng = Nothing
Set rng = Nothing
Set c_rows = Nothing
Set c_cells = Nothing
Exit Sub
err_handler:
If Not oWB Is Nothing Then
oWB.Close False
End If
Resume resume_here
End Sub
'arnelgp
'Public Function XlApp() As Excel.Application
Public Function XlApp() As Object
'Static xl As Excel.Application
Static xl As Object
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
xl.DisplayAlerts = False
End If
Set XlApp = xl
End Function
'https://www.bing.com/search?q=vba+sort+collection&cvid=3fbc9ee9fe0b467b9185ad5798af4ad4&FORM=ANAB01&PC=U531
Public Sub SortCollectionAsc(ByRef cFruit As Collection)
Dim i As Integer, j As Integer
Dim vTemp As Variant
'Two loops to bubble sort
For i = 1 To cFruit.Count - 1
For j = i + 1 To cFruit.Count
If cFruit(i) > cFruit(j) Then
'store the lesser item
vTemp = cFruit(j)
'remove the lesser item
cFruit.Remove j
're-add the lesser item before the
'greater Item
cFruit.Add vTemp, vTemp, i
End If
Next j
Next i
End Sub
'arnelgp
Public Function removeUnwatedChars(ByVal sText As String) As String
With CreateObject("VBScript.RegExp")
.Pattern = "([^\w\s])"
.Global = True
.IgnoreCase = True
.MultiLine = True
sText = .Replace(sText, "$1")
End With
removeUnwatedChars = sText
End Function
ok, this will Create new row and Split those values that has Chr(10) on them.
if there is 1 Chr(10) on the cell, it add another row of same data.
if there are 2 it will create addional 2 rows.
before importing the excel workbook.
call the function ExpandChar10(), passing the fullpath+name of the excel to import.
'arnelgp
Public Sub ExpandChar10(ByVal WB As String)
'early binding
'Dim oWB As Excel.Workbook
'Dim oSH As Excel.Worksheet
'Dim rng As Excel.Range
'Dim r As Excel.Range
On Error GoTo err_handler
'late binding
Dim oWB As Object
Dim oSH As Object
Dim rng As Object
Dim r As Object
'Dim allrng As Excel.Range
Dim allrng As Object
Dim i As Integer, j As Integer, k As Integer
Dim c_cells As Collection
Dim c_rows As Collection
Dim theValue As Variant
Dim aValues As Variant
'exit if invalid filename
If Len(Dir$(WB)) < 1 Then
Exit Sub
End If
'no validation if the workbook is password protected.
Set oWB = XlApp.Workbooks.Open(WB)
For Each oSH In oWB.Worksheets
Set c_cells = New Collection
Set allrng = oSH.UsedRange
For Each rng In allrng
theValue = rng.Value & vbNullString
If theValue Like "*" & Chr(10) & "*" Then
c_cells.Add rng.Address
End If
Next
Set c_rows = New Collection
For i = 1 To c_cells.Count
'Debug.Print oSH.Name & " " & c_cells(i)
'add the rows to collection
On Error Resume Next
c_rows.Add CLng(Mid$(c_cells(i), InStrRev(c_cells(i), "$") + 1)), Mid$(c_cells(i), InStrRev(c_cells(i), "$") + 1)
On Error GoTo err_handler
Next
'sort c_cells Descending
If c_rows.Count <> 0 Then
Call SortCollectionAsc(c_rows)
End If
For i = c_rows.Count To 1 Step -1
'copy the rows and remove the chr(10)
oSH.Rows(c_rows(i) & ":" & c_rows(i)).Select
XlApp.Selection.Copy
XlApp.Selection.Insert Shift:=-4121 'xlDown
'split the values with chr(10)
For j = 1 To c_cells.Count
If c_cells(j) Like ("*$" & c_rows(i)) Then
aValues = Split(oSH.Range(c_cells(j)).Value, Chr(10))
For k = 0 To UBound(aValues)
oSH.Range(c_cells(j)).Offset(k, 0).Value = removeUnwatedChars(aValues(k))
Next k
End If
Next j
Next i
Next
Set oSH = Nothing
oWB.Close True
resume_here:
Set oWB = Nothing
Set allrng = Nothing
Set rng = Nothing
Set c_rows = Nothing
Set c_cells = Nothing
Exit Sub
err_handler:
If Not oWB Is Nothing Then
oWB.Close False
End If
Resume resume_here
End Sub
'arnelgp
'Public Function XlApp() As Excel.Application
Public Function XlApp() As Object
'Static xl As Excel.Application
Static xl As Object
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
xl.DisplayAlerts = False
End If
Set XlApp = xl
End Function
'https://www.bing.com/search?q=vba+sort+collection&cvid=3fbc9ee9fe0b467b9185ad5798af4ad4&FORM=ANAB01&PC=U531
Public Sub SortCollectionAsc(ByRef cFruit As Collection)
Dim i As Integer, j As Integer
Dim vTemp As Variant
'Two loops to bubble sort
For i = 1 To cFruit.Count - 1
For j = i + 1 To cFruit.Count
If cFruit(i) > cFruit(j) Then
'store the lesser item
vTemp = cFruit(j)
'remove the lesser item
cFruit.Remove j
're-add the lesser item before the
'greater Item
cFruit.Add vTemp, vTemp, i
End If
Next j
Next i
End Sub
'arnelgp
Public Function removeUnwatedChars(ByVal sText As String) As String
With CreateObject("VBScript.RegExp")
.Pattern = "([^\w\s])"
.Global = True
.IgnoreCase = True
.MultiLine = True
sText = .Replace(sText, "$1")
End With
removeUnwatedChars = sText
End Function
i have already imported the data so i want to have the data imported to be altered, will have to change the code a bit to select table "DATA" and not to look at the spreadsheet
i have different spreadsheets with different data,
'arnelgp
Public Sub ExpandChar10(ByVal WB As String, Optional ByVal WSName As String = "")
'early binding
'Dim oWB As Excel.Workbook
'Dim oSH As Excel.Worksheet
'Dim rng As Excel.Range
'Dim r As Excel.Range
On Error GoTo err_handler
'late binding
Dim oWB As Object
Dim oSH As Object
Dim rng As Object
Dim r As Object
'Dim allrng As Excel.Range
Dim allrng As Object
Dim i As Integer, j As Integer, k As Integer
Dim c_cells As Collection
Dim c_rows As Collection
Dim theValue As Variant
Dim aValues As Variant
'exit if invalid filename
If Len(Dir$(WB)) < 1 Then
Exit Sub
End If
'no validation if the workbook is password protected.
Set oWB = XlApp.Workbooks.Open(WB)
For Each oSH In oWB.Worksheets
If oSH.Name = WSName Or Len(WSName) = 0 Then
Set c_cells = New Collection
Set allrng = oSH.UsedRange
For Each rng In allrng
theValue = rng.Value & vbNullString
If theValue Like "*" & Chr(10) & "*" Then
c_cells.Add rng.Address
End If
Next
Set c_rows = New Collection
For i = 1 To c_cells.Count
'Debug.Print oSH.Name & " " & c_cells(i)
'add the rows to collection
On Error Resume Next
c_rows.Add CLng(Mid$(c_cells(i), InStrRev(c_cells(i), "$") + 1)), Mid$(c_cells(i), InStrRev(c_cells(i), "$") + 1)
On Error GoTo err_handler
Next
'sort c_cells Descending
If c_rows.Count <> 0 Then
Call SortCollectionAsc(c_rows)
End If
For i = c_rows.Count To 1 Step -1
'copy the rows and remove the chr(10)
oSH.Rows(c_rows(i) & ":" & c_rows(i)).Select
XlApp.Selection.Copy
XlApp.Selection.Insert Shift:=-4121 'xlDown
'split the values with chr(10)
For j = 1 To c_cells.Count
If c_cells(j) Like ("*$" & c_rows(i)) Then
aValues = Split(oSH.Range(c_cells(j)).Value, Chr(10))
For k = 0 To UBound(aValues)
oSH.Range(c_cells(j)).Offset(k, 0).Value = removeUnwatedChars(aValues(k))
Next k
End If
Next j
Next i
End If
Next
Set oSH = Nothing
oWB.Close True
resume_here:
Set oWB = Nothing
Set allrng = Nothing
Set rng = Nothing
Set c_rows = Nothing
Set c_cells = Nothing
Exit Sub
err_handler:
If Not oWB Is Nothing Then
oWB.Close False
End If
Resume resume_here
End Sub
'arnelgp
Public Sub ExpandChar10(ByVal WB As String, Optional ByVal WSName As String = "")
'early binding
'Dim oWB As Excel.Workbook
'Dim oSH As Excel.Worksheet
'Dim rng As Excel.Range
'Dim r As Excel.Range
On Error GoTo err_handler
'late binding
Dim oWB As Object
Dim oSH As Object
Dim rng As Object
Dim r As Object
'Dim allrng As Excel.Range
Dim allrng As Object
Dim i As Integer, j As Integer, k As Integer
Dim c_cells As Collection
Dim c_rows As Collection
Dim theValue As Variant
Dim aValues As Variant
'exit if invalid filename
If Len(Dir$(WB)) < 1 Then
Exit Sub
End If
'no validation if the workbook is password protected.
Set oWB = XlApp.Workbooks.Open(WB)
For Each oSH In oWB.Worksheets
If oSH.Name = WSName Or Len(WSName) = 0 Then
Set c_cells = New Collection
Set allrng = oSH.UsedRange
For Each rng In allrng
theValue = rng.Value & vbNullString
If theValue Like "*" & Chr(10) & "*" Then
c_cells.Add rng.Address
End If
Next
Set c_rows = New Collection
For i = 1 To c_cells.Count
'Debug.Print oSH.Name & " " & c_cells(i)
'add the rows to collection
On Error Resume Next
c_rows.Add CLng(Mid$(c_cells(i), InStrRev(c_cells(i), "$") + 1)), Mid$(c_cells(i), InStrRev(c_cells(i), "$") + 1)
On Error GoTo err_handler
Next
'sort c_cells Descending
If c_rows.Count <> 0 Then
Call SortCollectionAsc(c_rows)
End If
For i = c_rows.Count To 1 Step -1
'copy the rows and remove the chr(10)
oSH.Rows(c_rows(i) & ":" & c_rows(i)).Select
XlApp.Selection.Copy
XlApp.Selection.Insert Shift:=-4121 'xlDown
'split the values with chr(10)
For j = 1 To c_cells.Count
If c_cells(j) Like ("*$" & c_rows(i)) Then
aValues = Split(oSH.Range(c_cells(j)).Value, Chr(10))
For k = 0 To UBound(aValues)
oSH.Range(c_cells(j)).Offset(k, 0).Value = removeUnwatedChars(aValues(k))
Next k
End If
Next j
Next i
End If
Next
Set oSH = Nothing
oWB.Close True
resume_here:
Set oWB = Nothing
Set allrng = Nothing
Set rng = Nothing
Set c_rows = Nothing
Set c_cells = Nothing
Exit Sub
err_handler:
If Not oWB Is Nothing Then
oWB.Close False
End If
Resume resume_here
End Sub
no, i have imported all the sheets into a table called data, then do the alteration, i don't event want to reference to any workbook, will make evertthing more complicated
