- Katılım
- 3 Kasım 2012
- Mesajlar
- 10
- Excel Vers. ve Dili
- EXCEL2010-TÜRKÇE
Sub SON_VERILERI_AKTAR()
Dim S1 As Worksheet, S2 As Worksheet
Dim X As Long, Y As Byte, Bul As Range, Satir As Long
Application.ScreenUpdating = False
Set S1 = Sheets("veri")
Set S2 = Sheets("üretimtablosu")
S1.Columns("AA:AA").Clear
S1.Columns("D
").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("AA1"), Unique:=True
S2.Range("A2:L" & Rows.Count).Clear
Satir = 2
For X = 2 To S1.Cells(Rows.Count, "AA").End(3).Row
Set Bul = S1.Range("D
").Find(S1.Cells(X, "AA"), , , xlWhole, , xlPrevious)
If Not Bul Is Nothing Then
Bul.EntireRow.Copy S2.Cells(Satir, 1)
If WorksheetFunction.CountA(S1.Range("A" & Bul.Row & ":L" & Bul.Row)) <> 12 Then
Set Bul = S1.Range("D
").FindPrevious(Bul)
If Not Bul Is Nothing Then
For Y = 1 To 12
If S2.Cells(Satir, Y) = "" Then
S1.Cells(Bul.Row, Y).Copy S2.Cells(Satir, Y)
End If
Next
End If
End If
Satir = Satir + 1
End If
Next
Set Bul = Nothing
Set S1 = Nothing
Set S2 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
hangi kodla ne yapılmış detaylı açıklama yaparsanız sevinirim
Dim S1 As Worksheet, S2 As Worksheet
Dim X As Long, Y As Byte, Bul As Range, Satir As Long
Application.ScreenUpdating = False
Set S1 = Sheets("veri")
Set S2 = Sheets("üretimtablosu")
S1.Columns("AA:AA").Clear
S1.Columns("D
S2.Range("A2:L" & Rows.Count).Clear
Satir = 2
For X = 2 To S1.Cells(Rows.Count, "AA").End(3).Row
Set Bul = S1.Range("D
If Not Bul Is Nothing Then
Bul.EntireRow.Copy S2.Cells(Satir, 1)
If WorksheetFunction.CountA(S1.Range("A" & Bul.Row & ":L" & Bul.Row)) <> 12 Then
Set Bul = S1.Range("D
If Not Bul Is Nothing Then
For Y = 1 To 12
If S2.Cells(Satir, Y) = "" Then
S1.Cells(Bul.Row, Y).Copy S2.Cells(Satir, Y)
End If
Next
End If
End If
Satir = Satir + 1
End If
Next
Set Bul = Nothing
Set S1 = Nothing
Set S2 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
hangi kodla ne yapılmış detaylı açıklama yaparsanız sevinirim