- Katılım
- 12 Ocak 2007
- Mesajlar
- 465
- Excel Vers. ve Dili
- 2003
sn dostlar siteden almış olduğum bir çalışmada mevcut olan veri aktar kodunu aşağıya ekliyorum.zamanınız olurda yardımcı olursanız sevinirim.burada sanırım sıra no vermekle ilgili bir satır yada kod var ama hangisidir ben bilmiyorum.o kodu kaldırmak istiyorum yani otomatik sıra numarası vermesin istiyorum.saygılarımla
Sub Test()
Dim cn As Object, rs As Object
Dim array_accounts$(), i%
Set cn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
cn.Open _
"driver={microsoft excel driver (*.xls)};dbq=" & ThisWorkbook.FullName
rs.Open _
"select distinct [FİRMA ADI] from [VERİ$]", cn, 1, 3
While Not rs.EOF
i = i + 1
ReDim Preserve array_accounts$(i - 1)
array_accounts(i - 1) = rs(0)
rs.movenext
Wend
On Error Resume Next
Application.DisplayAlerts = False
For i = 0 To UBound(array_accounts)
Worksheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = array_accounts(i)
Sheets("VERİ").[e1:n1].Copy Sheets(Sheets.Count).[e1]
If Err Then Sheets(Sheets.Count).Delete: Err.Clear
Next
Application.DisplayAlerts = True
For i = 0 To UBound(array_accounts)
Set rs = cn.Execute( _
"select * from [VERİ$] where [FİRMA ADI] ='" & array_accounts(i) & "'")
Sheets("" & array_accounts(i)).[e2:n65536].ClearContents
Sheets("" & array_accounts(i)).[e2].CopyFromRecordset rs
Next
rs.Close
cn.Close
Erase array_accounts
Set rs = Nothing
Set cn = Nothing
End Sub
Sub Test()
Dim cn As Object, rs As Object
Dim array_accounts$(), i%
Set cn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
cn.Open _
"driver={microsoft excel driver (*.xls)};dbq=" & ThisWorkbook.FullName
rs.Open _
"select distinct [FİRMA ADI] from [VERİ$]", cn, 1, 3
While Not rs.EOF
i = i + 1
ReDim Preserve array_accounts$(i - 1)
array_accounts(i - 1) = rs(0)
rs.movenext
Wend
On Error Resume Next
Application.DisplayAlerts = False
For i = 0 To UBound(array_accounts)
Worksheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = array_accounts(i)
Sheets("VERİ").[e1:n1].Copy Sheets(Sheets.Count).[e1]
If Err Then Sheets(Sheets.Count).Delete: Err.Clear
Next
Application.DisplayAlerts = True
For i = 0 To UBound(array_accounts)
Set rs = cn.Execute( _
"select * from [VERİ$] where [FİRMA ADI] ='" & array_accounts(i) & "'")
Sheets("" & array_accounts(i)).[e2:n65536].ClearContents
Sheets("" & array_accounts(i)).[e2].CopyFromRecordset rs
Next
rs.Close
cn.Close
Erase array_accounts
Set rs = Nothing
Set cn = Nothing
End Sub