AccessTr.neT
copy Yapıştır ile Excelden veri alımı - Baskı Önizleme

+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Access (https://accesstr.net/forum-microsoft-access.html)
+--- Forum: Access Örnekleri ve Uygulamaları (https://accesstr.net/forum-access-ornekleri-ve-uygulamalari.html)
+--- Konu Başlığı: copy Yapıştır ile Excelden veri alımı (/konu-copy-yapistir-ile-excelden-veri-alimi.html)



copy Yapıştır ile Excelden veri alımı - fatih karagöl - 02/04/2013

Selamlar.
Forumda sıklıkla excelden accese veri girişi sorularına denk geliyorum.
Aşağıdaki fonksiyon 8 kolonlu bir datasheet formuna veri almaktadır.
Örnek eklemiyorum çünkü alınacak veri yapısı değiştikçe kodda değişecektir.
Kodun genel mantığı anlamak gerekmektedir.
Üstadlardan kodun iyileştirilmesi amacı ile düzeltme gelirse ayrıca memnun olurum.
Birilerinin işine yaraması dileği ile

Private Sub copyPastFromExcell()
Dim intAccount As Long
Dim lAcc As Integer
Dim clipboard As MSForms.DataObject
Dim ctl As Control


'SessionInformation
'**********************************************************************************
'**********************************************************************************
'**********************************************************************************

Set clipboard = New MSForms.DataObject
fSiraNo = Me.CurrentRecord
strKolon = Me.ActiveControl.Name

clipboard.GetFromClipboard
clipText = clipboard.GetText
clipTextSub = clipboard.GetText
Set clipboard = Nothing
xDelta = Me.ActiveControl.ColumnOrder()
W = 8 - Me.ActiveControl.ColumnOrder()

l = Len(clipText)
For i = 1 To l
If IsNumeric(Right(clipText, i)) Then GoTo temiz:
If IsCharAlphaNumeric(Asc(Right(clipText, i))) Then GoTo temiz:
clipTextSub = Left(clipText, l - i)
Next
temiz:
clipText = clipTextSub
starter = xDelta

Do While Not clipText = ""
If InStr(clipText, Chr(10)) > 0 Then iRow = Mid(clipText, 1, InStr(clipText, Chr(10)) - 2) Else iRow = clipText
'----------------------------------------------------------------
Do While Not iRow = ""
If InStr(iRow, vbTab) > 0 Then iRecord = Left(iRow, InStr(iRow, vbTab) - 1) Else iRecord = iRow
If Right(iRecord, 1) = vbTab Then iRecord = Left(iRecord, Len(iRecord) - 1)
For Each ctl In Me.Controls
If ctl.ControlType = 109 Then
If ctl.ColumnOrder() = starter Then
ctl.value = iRecord
If InStr(iRow, vbTab) > 0 Then iRow = Mid(iRow, InStr(iRow, vbTab) + 1) Else iRow = "": starter = 8
starter = starter + 1
Exit For
End If
End If
Next
If starter = 8 Then
fSiraNo = fSiraNo + 1
DoCmd.GoToRecord , , acGoTo, fSiraNo
iRow = ""
starter = xDelta
End If
Loop
'----------------------------------------------------------------

fSiraNo = fSiraNo + 1
DoCmd.GoToRecord , , acGoTo, fSiraNo
starter = xDelta
If InStr(clipText, Chr(10)) > 0 Then clipText = Mid(clipText, InStr(clipText, Chr(10)) + 1) Else clipText = ""
Loop

Me.Recalc
'Me.Refresh

'hariciVeriUygunlugu

'***************************************************************************************************
End Sub