Abey kodları düzenlemiştim ve Aktar sub kodunuda ayarlamıştım bir deneyin dictionary ile yaptım.Sizin eklediğinizdosyayada bakarm.
Birde siz dosyayı indirmişsiniz ama ben sonradan güncelleyip tekrar eklemiştim 6.Mesajda.
Kod:
Sub Aktar(ByVal syf As Worksheet)
Dim bul, ara As Range, i As Integer, dic As Object, aranan As String
Set dic = CreateObject("Scripting.dictionary")
With ThisWorkbook.Worksheets("Kimya")
For i = 4 To 18
bul = Application.Match(syf.Cells(i, "B").Value2, .Range("C:C"), 0)
If Not IsError(bul) Then
'içerik eklenirse burdan tekrar düzenle
For Each ara In .Range("I" & bul & ":BU" & bul)
If Len(Trim(ara.Value)) > 0 Then
aranan = .Cells(2, ara.Column).Value
If Not dic.exists(aranan) Then dic(aranan) = 0
End If
Next
End If
Next
End With
If dic.Count > 0 Then syf.Range("G3").Resize(, dic.Count).Value = dic.keys
Set dic = Nothing
End Sub
Sub Aktar2(ByVal syf As Worksheet)
Dim bulW_W, bulPH, sayBul As Integer, sonToplam As Integer, sonSutunG As Integer
sayBul = 0
With syf
sonToplam = .Cells(Rows.Count, "E").End(3).Row 'E sütuna göre son satir no
bulW_W = Application.Match("w / w", .Range("D:D"), 0)
bulPH = Application.Match("pH", .Range("B:B"), 0)
If IsError(bulW_W) Then Exit Sub
If IsError(bulPH) Then Exit Sub
If WorksheetFunction.CountA(.Range("G" & sonToplam & ":XFD" & sonToplam)) = 0 Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
If bulPH - bulW_W > 1 Then .Range(.Cells(bulW_W + 1, 1), .Cells(bulPH - 1, 1)).EntireRow.Delete
sonSutunG = .Cells(sonToplam, Columns.Count).End(xlToLeft).Column
If sonSutunG < 7 Then GoTo sonSub
ReDim arrBekle(1 To 3, 1 To 1)
For i = 7 To sonSutunG 'F sütun
If .Cells(sonToplam, i).Value2 > 0 Then
sayBul = sayBul + 1
ReDim Preserve arrBekle(1 To 3, 1 To sayBul) '3 olma sebebi C sütunu oldugu icin
arrBekle(1, sayBul) = .Cells(3, i).Value
'arrBekle(2, sayBul) = "%"
arrBekle(2, sayBul) = ""
arrBekle(3, sayBul) = .Cells(sonToplam, i).Value
End If
Next
sonSub:
If sayBul > 0 Then
.Range("A" & bulW_W + 1).Resize(sayBul).EntireRow.Insert
.Range("B" & bulW_W + 1).Resize(sayBul, 3).Value = Application.Transpose(arrBekle)
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End With
End Sub
Son dosyada sayfa adlarına gerek kalmadı ben change koduna ekledim parametre olarak alttaki gibi.
Kod:
Aktar ActiveSheet
Aktar2 ActiveSheet
deneme çalışma dizi.rar
(Dosya Boyutu: 74,63 KB | İndirme Sayısı: 2)
