- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,843
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
Bu kodlar için açıklama
Ana dosyanıza yeni bir boş sayfa ekleyin ve adını da (veri) sayfası yapın diğer sayfanızda makro (veri_al9) bu kodu çalıştırın
not: diğer sayfanızda üçüncü satırda aranan verileriniz olmalı tam 14 sütün olmalı
kod:
Ana dosyanıza yeni bir boş sayfa ekleyin ve adını da (veri) sayfası yapın diğer sayfanızda makro (veri_al9) bu kodu çalıştırın
not: diğer sayfanızda üçüncü satırda aranan verileriniz olmalı tam 14 sütün olmalı
kod:
Kod:
Sub veri_al9()
Sheets("veri").Cells.ClearContents
Range(Cells(3, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Rows("3:" & Rows.Count).Interior.ColorIndex = xlNone
Liste1 (ThisWorkbook.Path)
MsgBox "işlem tamam"
End Sub
Private Sub Liste1(Yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")
ReDim yer(100)
aranan_Uzanti = fL.GetExtensionName(Application.AddIns.Item(1).FullName)
For Each dosya In fL.GetFolder(Yol).Files
If ThisWorkbook.Name = dosya.Name Then
GoTo Atla2
End If
If "~$" = Mid(dosya.Name, 1, 2) Then
GoTo Atla2
End If
uzanti = fL.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoTo Atla1
End If
End If
If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoTo Atla1
Else
End If
End If
For kak = 1 To 100
yer(kak) = ""
Next
say1 = 0
Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & dosya & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then
son1 = Left$(son1, Len(son1) - 1)
deg = Split(son1, "#")
Son = UBound(deg)
If Son = 0 Then
Else
say1 = say1 + 1
yer(say1) = Replace(son1, "#", ".")
End If
say1 = say1 + 1
yer(say1) = son1
End If
End If
End If
End If
End If
Next
Data.Close
Set Data = Nothing
Set Katalog = Nothing
For mat = 1 To say1
SayfaAdi = yer(mat)
Dim Kayit As ADODB.Recordset
Set Kayit = New ADODB.Recordset
Dosya_adi = fL.GetBaseName(dosya)
uzanti = fL.GetExtensionName(dosya)
Sayfa_adı = yer(mat)
If uzanti = "xls" Then
baglan = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 8.0;HDR=yes""" 'ofis 2003
Kayit.Open "SELECT * FROM [" & Sayfa_adı & "$] ", baglan, adOpenKeyset, adLockOptimistic
ElseIf uzanti = "xlsb" Or uzanti = "xlsx" Or uzanti = "xlsm" Then
baglan = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 12.0;HDR=yes""" 'ofis 2007
Kayit.Open "SELECT * FROM [" & Sayfa_adı & "$] ", baglan, adOpenKeyset, adLockOptimistic
Else
End If
Sheets("veri").Range("A1").CopyFromRecordset Kayit
Kayit.Close
Set Kayit = Nothing
Atla1:
Next mat
'End If
Atla2:
Next
bul_Click
Sheets("veri").Cells.ClearContents
On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste1 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
Sub bul_Click()
For m = 1 To 14
ad = Cells(2, m)
deger = Sheets("veri").Name
Set Sh = Sheets("veri")
yer = xlFormulas
yer1 = xlPart
'yer = xlValues
'yer1 = xlWhole
If WorksheetFunction.CountA(Sh.Cells) > 0 Then
sat = Sh.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = Sh.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Else
Exit Sub
End If
If WorksheetFunction.CountA(Cells) > 0 Then
sonsat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
End If
If sonsat < 3 Then sonsat = 3
Dim SütunAdı As String
For k = 2 To sat
SütunAdı = Split(Sh.Cells(1, Val(sut)).Address, "$")(1)
sat1 = 0
With Sh.Range("A" & k & ":" & SütunAdı & k)
Set d = .Find(What:=ad, After:=.Cells(.Cells.Count), LookIn:=yer, lookat:=yer1, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not d Is Nothing Then
FirstAddress = d.Address
Do
sat1 = sat1 + 1
If sat1 = 1 Then
Y = 0
For r = 1 To 14
Y = Y + 1
Cells(sonsat, r) = Sh.Cells(d.Row, r)
Next
Cells(sonsat, d.Column).Interior.Color = 65535
sonsat = sonsat + 1
End If
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
Next
Next m
Set Sh = Nothing
End Sub
