Rica ederim abey bir iki satır değiştirdim deneyin.
Private Sub CommandButton16_Click()
Dim bulbaslikVeri As Range, bulveri As Range, xx As Byte
Dim i As Long, deger As String, arr(), say As Byte, sonTasr As Long, veri
Dim syfVeri As Worksheet: Set syfVeri = ThisWorkbook.Sheets("VERÝ")
Dim syftasar As Worksheet: Set syftasar = ThisWorkbook.Sheets("TASARI")
Const comboSayisi_ilk As Byte = 6
Const comboSayisi_son As Byte = 14
say = 0
For x = comboSayisi_ilk To comboSayisi_son
If Me.Controls("ComboBox" & x).Value <> "" Then say = say + 1
Next
If say = 0 Then
MsgBox "combolardan secim yap...", vbCritical, "Hata"
Exit Sub
End If
With syftasar
If WorksheetFunction.CountA(.Range("A2:A" & Rows.Count)) = 0 Then
MsgBox " Tasari sayfasinda veri yok...", vbCritical, "Hata"
Exit Sub
Else
sonTasr = .Cells(Rows.Count, 1).End(3).Row
ReDim arr(1 To sonTasr, 1 To say)
End If
.Range(.Cells(1, comboSayisi_ilk), .Cells(Rows.Count, Columns.Count)).ClearContents
Application.ScreenUpdating = False
For x = comboSayisi_ilk To comboSayisi_son
deger = Me.Controls("ComboBox" & x).Value
If Trim(deger) <> "" Then
i = 1
veri = .Range("B2:B" & sonTasr).Value
For i = 1 To UBound(veri)
Set bulveri = syfVeri.Columns(2).Find(veri(i, 1), , xlValues, 1)
Set bulbaslikVeri = syfVeri.Rows(1).Find(deger, , , 1)
If Not bulbaslikVeri Is Nothing Then
For xx = 1 To say
arr(i, xx) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)
Next xx
End If
Next
.Cells(1, bulbaslikVeri.Column).Value = deger
syftasar.Cells(2, bulbaslikVeri.Column).Resize(UBound(arr), 1).Value = arr
End If
Next x
Application.ScreenUpdating = True
MsgBox "Bitti"
Erase arr: Erase veri
End With
syftasar.Cells.EntireColumn.AutoFit
syftasar.Cells.EntireRow.AutoFit
Set bulbaslikVeri = Nothing: Set bulveri = Nothing
Set syfVeri = Nothing: Set syftasar = Nothing
End Sub
(17/04/2021, 13:28)feraz yazdı: Rica ederim abey bir iki satır değiştirdim deneyin.
Private Sub CommandButton16_Click()
Dim bulbaslikVeri As Range, bulveri As Range, xx As Byte
Dim i As Long, deger As String, arr(), say As Byte, sonTasr As Long, veri
Dim syfVeri As Worksheet: Set syfVeri = ThisWorkbook.Sheets("VERÝ")
Dim syftasar As Worksheet: Set syftasar = ThisWorkbook.Sheets("TASARI")
Const comboSayisi_ilk As Byte = 6
Const comboSayisi_son As Byte = 14
say = 0
For x = comboSayisi_ilk To comboSayisi_son
If Me.Controls("ComboBox" & x).Value <> "" Then say = say + 1
Next
If say = 0 Then
MsgBox "combolardan secim yap...", vbCritical, "Hata"
Exit Sub
End If
With syftasar
If WorksheetFunction.CountA(.Range("A2:A" & Rows.Count)) = 0 Then
MsgBox " Tasari sayfasinda veri yok...", vbCritical, "Hata"
Exit Sub
Else
sonTasr = .Cells(Rows.Count, 1).End(3).Row
ReDim arr(1 To sonTasr, 1 To say)
End If
.Range(.Cells(1, comboSayisi_ilk), .Cells(Rows.Count, Columns.Count)).ClearContents
Application.ScreenUpdating = False
For x = comboSayisi_ilk To comboSayisi_son
deger = Me.Controls("ComboBox" & x).Value
If Trim(deger) <> "" Then
i = 1
veri = .Range("B2:B" & sonTasr).Value
For i = 1 To UBound(veri)
Set bulveri = syfVeri.Columns(2).Find(veri(i, 1), , xlValues, 1)
Set bulbaslikVeri = syfVeri.Rows(1).Find(deger, , , , 1)
If Not bulbaslikVeri Is Nothing Then
For xx = 1 To say
arr(i, xx) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)
Next xx
End If
Next
.Cells(1, bulbaslikVeri.Column).Value = deger
syftasar.Cells(2, bulbaslikVeri.Column).Resize(UBound(arr), 1).Value = arr
End If
Next x
Application.ScreenUpdating = True
MsgBox "Bitti"
Erase arr: Erase veri
End With
syftasar.Cells.EntireColumn.AutoFit
syftasar.Cells.EntireRow.AutoFit
Set bulbaslikVeri = Nothing: Set bulveri = Nothing
Set syfVeri = Nothing: Set syftasar = Nothing
End Sub
Hocam malesef ilgili sütun için ComBoBoxta seçilen veri TASARI sayfasında farklı sütuna geliyor malesef
(17/04/2021, 17:07)hayalibey yazdı: (17/04/2021, 13:28)feraz yazdı: Rica ederim abey bir iki satır değiştirdim deneyin.
Private Sub CommandButton16_Click()
Dim bulbaslikVeri As Range, bulveri As Range, xx As Byte
Dim i As Long, deger As String, arr(), say As Byte, sonTasr As Long, veri
Dim syfVeri As Worksheet: Set syfVeri = ThisWorkbook.Sheets("VERÝ")
Dim syftasar As Worksheet: Set syftasar = ThisWorkbook.Sheets("TASARI")
Const comboSayisi_ilk As Byte = 6
Const comboSayisi_son As Byte = 14
say = 0
For x = comboSayisi_ilk To comboSayisi_son
If Me.Controls("ComboBox" & x).Value <> "" Then say = say + 1
Next
If say = 0 Then
MsgBox "combolardan secim yap...", vbCritical, "Hata"
Exit Sub
End If
With syftasar
If WorksheetFunction.CountA(.Range("A2:A" & Rows.Count)) = 0 Then
MsgBox " Tasari sayfasinda veri yok...", vbCritical, "Hata"
Exit Sub
Else
sonTasr = .Cells(Rows.Count, 1).End(3).Row
ReDim arr(1 To sonTasr, 1 To say)
End If
.Range(.Cells(1, comboSayisi_ilk), .Cells(Rows.Count, Columns.Count)).ClearContents
Application.ScreenUpdating = False
For x = comboSayisi_ilk To comboSayisi_son
deger = Me.Controls("ComboBox" & x).Value
If Trim(deger) <> "" Then
i = 1
veri = .Range("B2:B" & sonTasr).Value
For i = 1 To UBound(veri)
Set bulveri = syfVeri.Columns(2).Find(veri(i, 1), , xlValues, 1)
Set bulbaslikVeri = syfVeri.Rows(1).Find(deger, , , , 1)
If Not bulbaslikVeri Is Nothing Then
For xx = 1 To say
arr(i, xx) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)
Next xx
End If
Next
.Cells(1, bulbaslikVeri.Column).Value = deger
syftasar.Cells(2, bulbaslikVeri.Column).Resize(UBound(arr), 1).Value = arr
End If
Next x
Application.ScreenUpdating = True
MsgBox "Bitti"
Erase arr: Erase veri
End With
syftasar.Cells.EntireColumn.AutoFit
syftasar.Cells.EntireRow.AutoFit
Set bulbaslikVeri = Nothing: Set bulveri = Nothing
Set syfVeri = Nothing: Set syftasar = Nothing
End Sub
Hocam malesef ilgili sütun için ComBoBoxta seçilen veri TASARI sayfasında farklı sütuna geliyor malesef
Farklı gelmesi imkansız abey
Don dosyanızı ekleyin bakayım bir.