(18/11/2023, 00:04)feraz yazdı: Aslında biraz daha kod kısalabilinir ama algoritmam iyi olmadığı için istediğimi yapamadım ama çalışıyor.
Yavaş çalışacakmı kendi dosyanızda deneyin bir.
PHP Kod:Private Sub CommandButton1_Click()
Dim i As Long, ii As Long, son As Long, say As Long
Dim syf As Worksheet, aralik(), kac As Long, syfRucu As Worksheet
Dim b2 As Long, f2 As Long, ilktrh As Long, sontrh As Long
On Error Resume Next
Set syf = ThisWorkbook.Worksheets(Range("I1").Value)
On Error GoTo 0
Set syfRucu = ThisWorkbook.Worksheets("Rucü Yüklenici")
say = 1
b2 = Cells(2, "B").Value2
f2 = syfRucu.Cells(2, "F").Value2
For i = syfRucu.Cells(2, "B").Value2 To (syfRucu.Cells(2, "F").Value2)
ReDim Preserve aralik(1 To say)
aralik(say) = i
say = say + 1
Next
say = 5
Union(syfRucu.Range("B5:C" & Rows.Count), syfRucu.Range("E5:E" & Rows.Count)).Value = ""
If Not syf Is Nothing Then
With syf
For i = 2 To .Cells(Rows.Count, "A").End(3).Row + 1
ilktrh = .Cells(i, "B").Value2
sontrh = .Cells(i, "C").Value2
For ii = ilktrh To sontrh
On Error Resume Next
kac = 0
kac = WorksheetFunction.Match(ii, aralik, 0)
On Error GoTo 0
If kac > 0 Then
If b2 >= ilktrh Then
syfRucu.Range("B" & say).Value = b2
Else
syfRucu.Range("B" & say).Value = ilktrh
End If
syfRucu.Range("C" & say).Value = .Cells(i, "C").Value
say = say + 1
Exit For
End If
Next
Next
End With
End If
Set syf = Nothing: Set syfRucu = Nothing
End Sub
iyi günler;
iyi haftalar, yazmış olduğunuz kodu aldığımda program kod kısmına gidip run yaptığımda çalışıyor. Birde firma isimleri gelmiyor. Aynı zamanda kişi 30.07.2007 ayrıldığını düşünürsek, sistem 30.07.2007 yerine 31.07.2007 atıyor.
