Merhaba arkadaşlar.
İnsan Kaynakları üzerine bir firma için bir çalışma yapmaktayım. Adaylar excel formatındaki CV'yi doldurup, dosyanın ismini TC'leri ile değiştirip firmaya gönderecek ve firma da bu CV'lerin içeriklerini tek bir dosyada birleştirerek daha hızlı kararlar alabilecek veya veri ambarı olarak saklayacaklardır.
Aynı klasör altındaki tüm excel dosyalarından fotoğrafları çekebiliyorum. birleştirilmiş hücrelerdeki metin bilgilerini de çekebiliyorum ama bir türlü checkbox ların işaret bilgisini alamıyorum. Yardımcı olabilir misiniz?
(Checkboxları hem form hem de activex ten denedim olmadı.)
Kodlar aşağıdaki gibidir. İşyerinden upload yapamıyorum. Dosyayı yükleyemiyorum.
Private Sub CommandButton1_Click()
UserForm1.Hide
Dim klasor As Object
Dim KTP As Workbook, ASIII As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, yol As String
Dim HCR As Variant
Application.ScreenUpdating = False
Set ASIII = CreateObject("Excel.Application")
ASIII.Visible = False
yol = ThisWorkbook.Path & "\"
Liste (yol)
AltListe (yol)
A1 = ActiveWorkbook.Name
Set A1S1 = Workbooks(A1).Sheets("Sayfa1")
jjj = 3
Columns("B:B").ColumnWidth = 30
Dim DosyaSayisi As Integer
Dim DosyaSayisi2 As Integer
DosyaSayisi = TextBox1.Text
DosyaSayisi2 = DosyaSayisi
DosyaSayisi = (DosyaSayisi - 1) * 13 + 1
For iii = 14 To DosyaSayisi
Sheets(1).Cells(iii - 11, 1) = Sheets(1).Cells(iii, 1)
A2 = Sheets(1).Cells(iii, 1)
Rows(jjj & ":" & jjj).RowHeight = 179
Set KTP = ASIII.Workbooks.Open(yol & A2)
Set A2S2 = KTP.Sheets("CV")
'FOTOĞRAFIN KOPYALANMASI
A2S2.Range("O2
6").Copy
A1S1.Activate
With Worksheets("Sayfa1")
.Activate
.Range(Cells(jjj, 2), Cells(jjj, 2)).Select
.Pictures.Paste
End With
Application.CutCopyMode = False
Range(Cells(jjj, 2), Cells(jjj, 2)).Copy
With Worksheets("Sayfa1")
.Activate
.Range(Cells(jjj, 2), Cells(jjj, 2)).Select
.Pictures.Paste
End With
Application.CutCopyMode = False
'AD SOYADIN KOPYALANMASI
A2S2.Range("D77").Copy
A1S1.Activate
With Worksheets("Sayfa1")
.Activate
.Range(Cells(jjj + 1, 5), Cells(jjj + 1, 5)).Select
.Paste
End With
Application.CutCopyMode = False
Range(Cells(jjj + 1, 5), Cells(jjj + 1, 5)).Copy
Range(Cells(jjj, 5), Cells(jjj, 5)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.UnMerge
Range(Cells(jjj + 1, 5), Cells(jjj + 1, 5)).Select
Selection.Delete Shift:=xlToLeft
.
.
.
'Falan filan falan filan (Ad soyad gibi diğer metinleri çekiyorum.)
.
.
.
'Şunu denedim olmadı
'SÜRÜCÜ EHLİYETİ VAR KUTUCUĞU
A2S2.Activate
If ActiveSheet.Shapes("Onay Kutusu 10").OLEFormat.Object.Value = 1 Then
'If ActiveSheet.Shapes("Onay Kutusu 10").OLEFormat.Object.Value = True Then
A1S1.Activate
Sheets(1).Cells(jjj, 67) = "İşaretli"
Else
Sheets(1).Cells(jjj, 67) = "İşaretsiz"
End If
.
.
.
Gene falan filan falan filan (Diğer kutucukların kodları ama çalışmadığından dolayı buraları atlatıyorum)
.
.
.
KTP.Save: ASIII.Quit
Application.Wait Time + TimeSerial(0, 0, 5)
Next
Range("B2").Select
Selection.EntireRow.Delete
Range("C2").Select
Selection.EntireColumn.Delete
Range("C2").Select
Selection.EntireColumn.Delete
'FOTOĞRAFLARIN DÜZENLENMESİ
kkk = 3
For iii = 14 To DosyaSayisi
Range(Cells(kkk, 1), Cells(kkk + 11, 1)).Select
Selection.EntireRow.Delete
iii = iii + 12
kkk = kkk + 1
Next
For zzz = 1 To DosyaSayisi2 + 2
For ttt = 1 To jjj + 2
On Error Resume Next
Range("B" & zzz).Select
ActiveCell.FormulaR1C1 = ""
Range("B" & zzz).Select
ActiveSheet.Shapes.Range(Array("Picture " & ttt)).Select
Selection.Placement = xlMoveAndSize
ActiveSheet.Shapes.Range(Array("Resim " & ttt)).Select
Selection.Placement = xlMoveAndSize
ActiveSheet.Shapes.Range(Array("Fotoğraf " & ttt)).Select
Selection.Placement = xlMoveAndSize
Next
Next
'BAŞLIKLAR
Sheets(1).Cells(1, 2) = "FOTOĞRAF"
Sheets(1).Cells(1, 3) = "AD SOYAD"
Set klasor = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamam."
End Sub
'Dosyanın olduğu klasör yolu ve Klasördeki dosyaların Listesi
Private Sub Liste(yol As String)
Dim dosya As String, i As Long
dosya = Dir(yol & "*.xlsm")
i = 1
While dosya <> ""
DoEvents
i = i + 13
Cells(i, 1) = dosya
If Cells(i, 1) = "ZZZ_MAKRO_VERİ_ÇEKME.xlsm" Then
Cells(i, 1) = ""
End If
dosya = Dir
Wend
End Sub
Private Sub AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
On Error GoTo sonraki
For Each f In fL
dosya = Dir(f.Path & "*.xlsm")
While dosya <> ""
DoEvents
j = [a65000].End(3).Row + 13
Cells(j, 1) = yol & "" & dosya
dosya = Dir
Wend
AltListe (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
İnsan Kaynakları üzerine bir firma için bir çalışma yapmaktayım. Adaylar excel formatındaki CV'yi doldurup, dosyanın ismini TC'leri ile değiştirip firmaya gönderecek ve firma da bu CV'lerin içeriklerini tek bir dosyada birleştirerek daha hızlı kararlar alabilecek veya veri ambarı olarak saklayacaklardır.
Aynı klasör altındaki tüm excel dosyalarından fotoğrafları çekebiliyorum. birleştirilmiş hücrelerdeki metin bilgilerini de çekebiliyorum ama bir türlü checkbox ların işaret bilgisini alamıyorum. Yardımcı olabilir misiniz?
(Checkboxları hem form hem de activex ten denedim olmadı.)
Kodlar aşağıdaki gibidir. İşyerinden upload yapamıyorum. Dosyayı yükleyemiyorum.
Private Sub CommandButton1_Click()
UserForm1.Hide
Dim klasor As Object
Dim KTP As Workbook, ASIII As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, yol As String
Dim HCR As Variant
Application.ScreenUpdating = False
Set ASIII = CreateObject("Excel.Application")
ASIII.Visible = False
yol = ThisWorkbook.Path & "\"
Liste (yol)
AltListe (yol)
A1 = ActiveWorkbook.Name
Set A1S1 = Workbooks(A1).Sheets("Sayfa1")
jjj = 3
Columns("B:B").ColumnWidth = 30
Dim DosyaSayisi As Integer
Dim DosyaSayisi2 As Integer
DosyaSayisi = TextBox1.Text
DosyaSayisi2 = DosyaSayisi
DosyaSayisi = (DosyaSayisi - 1) * 13 + 1
For iii = 14 To DosyaSayisi
Sheets(1).Cells(iii - 11, 1) = Sheets(1).Cells(iii, 1)
A2 = Sheets(1).Cells(iii, 1)
Rows(jjj & ":" & jjj).RowHeight = 179
Set KTP = ASIII.Workbooks.Open(yol & A2)
Set A2S2 = KTP.Sheets("CV")
'FOTOĞRAFIN KOPYALANMASI
A2S2.Range("O2
6").CopyA1S1.Activate
With Worksheets("Sayfa1")
.Activate
.Range(Cells(jjj, 2), Cells(jjj, 2)).Select
.Pictures.Paste
End With
Application.CutCopyMode = False
Range(Cells(jjj, 2), Cells(jjj, 2)).Copy
With Worksheets("Sayfa1")
.Activate
.Range(Cells(jjj, 2), Cells(jjj, 2)).Select
.Pictures.Paste
End With
Application.CutCopyMode = False
'AD SOYADIN KOPYALANMASI
A2S2.Range("D7
7").CopyA1S1.Activate
With Worksheets("Sayfa1")
.Activate
.Range(Cells(jjj + 1, 5), Cells(jjj + 1, 5)).Select
.Paste
End With
Application.CutCopyMode = False
Range(Cells(jjj + 1, 5), Cells(jjj + 1, 5)).Copy
Range(Cells(jjj, 5), Cells(jjj, 5)).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.UnMerge
Range(Cells(jjj + 1, 5), Cells(jjj + 1, 5)).Select
Selection.Delete Shift:=xlToLeft
.
.
.
'Falan filan falan filan (Ad soyad gibi diğer metinleri çekiyorum.)
.
.
.
'Şunu denedim olmadı
'SÜRÜCÜ EHLİYETİ VAR KUTUCUĞU
A2S2.Activate
If ActiveSheet.Shapes("Onay Kutusu 10").OLEFormat.Object.Value = 1 Then
'If ActiveSheet.Shapes("Onay Kutusu 10").OLEFormat.Object.Value = True Then
A1S1.Activate
Sheets(1).Cells(jjj, 67) = "İşaretli"
Else
Sheets(1).Cells(jjj, 67) = "İşaretsiz"
End If
.
.
.
Gene falan filan falan filan (Diğer kutucukların kodları ama çalışmadığından dolayı buraları atlatıyorum)
.
.
.
KTP.Save: ASIII.Quit
Application.Wait Time + TimeSerial(0, 0, 5)
Next
Range("B2").Select
Selection.EntireRow.Delete
Range("C2").Select
Selection.EntireColumn.Delete
Range("C2").Select
Selection.EntireColumn.Delete
'FOTOĞRAFLARIN DÜZENLENMESİ
kkk = 3
For iii = 14 To DosyaSayisi
Range(Cells(kkk, 1), Cells(kkk + 11, 1)).Select
Selection.EntireRow.Delete
iii = iii + 12
kkk = kkk + 1
Next
For zzz = 1 To DosyaSayisi2 + 2
For ttt = 1 To jjj + 2
On Error Resume Next
Range("B" & zzz).Select
ActiveCell.FormulaR1C1 = ""
Range("B" & zzz).Select
ActiveSheet.Shapes.Range(Array("Picture " & ttt)).Select
Selection.Placement = xlMoveAndSize
ActiveSheet.Shapes.Range(Array("Resim " & ttt)).Select
Selection.Placement = xlMoveAndSize
ActiveSheet.Shapes.Range(Array("Fotoğraf " & ttt)).Select
Selection.Placement = xlMoveAndSize
Next
Next
'BAŞLIKLAR
Sheets(1).Cells(1, 2) = "FOTOĞRAF"
Sheets(1).Cells(1, 3) = "AD SOYAD"
Set klasor = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamam."
End Sub
'Dosyanın olduğu klasör yolu ve Klasördeki dosyaların Listesi
Private Sub Liste(yol As String)
Dim dosya As String, i As Long
dosya = Dir(yol & "*.xlsm")
i = 1
While dosya <> ""
DoEvents
i = i + 13
Cells(i, 1) = dosya
If Cells(i, 1) = "ZZZ_MAKRO_VERİ_ÇEKME.xlsm" Then
Cells(i, 1) = ""
End If
dosya = Dir
Wend
End Sub
Private Sub AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
On Error GoTo sonraki
For Each f In fL
dosya = Dir(f.Path & "*.xlsm")
While dosya <> ""
DoEvents
j = [a65000].End(3).Row + 13
Cells(j, 1) = yol & "" & dosya
dosya = Dir
Wend
AltListe (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
