Sayfadan veri alma

[nadirornek]

Merhaba

Ortak kullanılan bir dosya var.
Kitap1 deki veriler sürekli değişmektedir.Satır aralıklarında boşluklar mevcuttur.
Yapmak istediğim Kitap1 deki verileri Kitap2'ye ADI SOYADI CİNSİ NOSU
alt alta gelecek şekilde bir macro oluşturmak.

 

[Orion1]

Dosyanız ektedir.
2 dosyanında ayni klasörde olması lazımdır.

Option Base 1
Sub aktar_59()
Dim sh As Worksheet, sat As Long, a, myarr(), k As Byte, sat2 As Long
Dim x As Long, s As Long, sut As Byte
Sheets("Sayfa1").Select
Range("D3:G65536").ClearContents
Application.DisplayAlerts = False
If Workbooks.Open(ThisWorkbook.Path & "\Kitap1.xls").ReadOnly = True Then
    Workbooks("Kitap1.xls").Close
End If
Application.DisplayAlerts = True
Set sh = Workbooks("Kitap1.xls").Sheets("Sayfa1")
For k = 5 To 18
    sat = sh.Cells(65536, k).End(xlUp).Row
    If sat > sat2 Then sat2 = sat
Next k
If sat2 < 12 Then
    Workbooks("Kitap1.xls").Close False
    Set sh = Nothing
    Erase a
    Exit Sub
End If
a = sh.Range("E12:R65536").Value
ReDim myarr(1 To 4, 1 To UBound(a, 1))
For k = 1 To 4
    If k = 1 Then
        sut = 1
        ElseIf k = 2 Then
        sut = 4
        ElseIf k = 3 Then
        sut = 10
        ElseIf k = 4 Then
        sut = 14
    End If
    For x = 1 To UBound(a, 1)
        If a(x, sut) <> "" Then
            s = s + 1
            myarr(k, s) = a(x, sut)
        End If
    Next x
    s = 0
Next k
Workbooks("Kitap1.xls").Close False
ThisWorkbook.Activate
ReDim Preserve myarr(1 To 4, 1 To UBound(myarr, 2))
Application.ScreenUpdating = False
Range("D3").Resize(UBound(myarr, 2), 4) = Application.Transpose(myarr)
Application.ScreenUpdating = True
Erase a: Erase myarr: Set sh = Nothing
MsgBox "İşlem tamalandı" & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub

 

[nadirornek]

Evren bey
If Workbooks.Open(ThisWorkbook.Path & "\Kitap1.xls").ReadOnly = True Then

Bu satırda hata verdi

 

[Orion1]

Evren bey
If Workbooks.Open(ThisWorkbook.Path & "\Kitap1.xls").ReadOnly = True Then

Bu satırda hata verdi

Gerekli düzenlemeyi yaptım.
2 numaralaı mesajdan indirebilirisiniz.

 

[nadirornek]

Teşekkürler şimdi tamam elinize sağlık

 

[Orion1]

Teşekkürler şimdi tamam elinize sağlık

Rica ederim.