hücre içerisinde farklı nesneleri toplama?

eminecik' Alıntı:
Çok teşekkür ederim. Ellerinize sağlık.
Genişletmek için tıkla ...

Sütun veya satırları ötelemek için Kodun sadece kırmızı yerlerini değiştirmeniz yeterli

Kod: 
Option Explicit
Sub aktar()
Application.ScreenUpdating = False
Dim aranan, aranan1, adres, i, a, j, s, X, r, t, yer, sut, sut1, sat, sat1

[COLOR=Red]sut = 7    'g sütunu
sut1 = 10  'j sütunu
sat1 = 2   'başlangıç satırı[/COLOR]


Columns(sut1).ClearContents
Columns(sut1 + 1).ClearContents
Columns(sut1 + 2).ClearContents
Columns(sut1 + 3).ClearContents
Columns(sut1 + 4).ClearContents
Columns(sut1 + 5).ClearContents
sat = sat1
aranan = "+"
For r = sat1 To Cells(Rows.Count, sut).End(3).Row
adres = Cells(r, sut).Value & aranan
a = InStr(Trim(adres), aranan)
For j = 1 To Len(adres)
i = InStr(j, adres, aranan, vbTextCompare)
If i > 0 Then
yer = WorksheetFunction.Trim(Mid(Cells(r, sut).Value, j, i - j))
 
For t = 1 To Len(yer)
If IsNumeric(Mid(yer, 1, t)) = False Then
Cells(sat, sut1 + 4).Value = WorksheetFunction.Trim(Mid(yer, t, Len(yer)))
Cells(sat, sut1 + 3).Value = WorksheetFunction.Trim(Mid(yer, 1, t - 1))
Exit For
End If
Next
If Cells(sat, sut1 + 3).Value = "" Then
Cells(sat, sut1 + 5).Value = 1
End If
sat = sat + 1
j = i
End If
Next
Next

Set j = CreateObject("Scripting.Dictionary")
s = sat1
For Each X In Range(Cells(sat1, sut1 + 4), Cells(Cells(Rows.Count, sut1 + 4).End(3).Row, sut1 + 4))
aranan1 = Replace(Replace(LCase(X.Value), "İ", "i"), "I", "ı")
If aranan1 <> "" Then
If Not j.exists(aranan1) Then
j.Add aranan1, Nothing

Cells(s, sut1).Value = X.Value
Cells(s, sut1 + 2).Value = WorksheetFunction.SumIf(Range(Cells(sat1, sut1 + 4), Cells(65000, sut1 + 4)), Cells(s, sut1).Value, Range(Cells(sat1, sut1 + 3), Cells(50, sut1 + 3)))
If Cells(s, sut1 + 2).Value = 0 Then
Cells(s, sut1 + 2).Value = ""
End If
Cells(s, sut1 + 1).Value = WorksheetFunction.SumIf(Range(Cells(sat1, sut1 + 4), Cells(50, sut1 + 4)), Cells(s, sut1).Value, Range(Cells(sat1, sut1 + 5), Cells(50, sut1 + 5)))
If Cells(s, sut1 + 1).Value = 0 Then
Cells(s, sut1 + 1).Value = ""
End If
s = s + 1
End If
End If
Next X
Columns(sut1 + 3).ClearContents
Columns(sut1 + 4).ClearContents
Columns(sut1 + 5).ClearContents
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub
 
halit3' Alıntı:
Sütun veya satırları ötelemek için Kodun sadece kırmızı yerlerini değiştirmeniz yeterli

Kod: 
Option Explicit
Sub aktar()
Application.ScreenUpdating = False
Dim aranan, aranan1, adres, i, a, j, s, X, r, t, yer, sut, sut1, sat, sat1

[COLOR=Red]sut = 7    'g sütunu
sut1 = 10  'j sütunu
sat1 = 2   'başlangıç satırı[/COLOR]


Columns(sut1).ClearContents
Columns(sut1 + 1).ClearContents
Columns(sut1 + 2).ClearContents
Columns(sut1 + 3).ClearContents
Columns(sut1 + 4).ClearContents
Columns(sut1 + 5).ClearContents
sat = sat1
aranan = "+"
For r = sat1 To Cells(Rows.Count, sut).End(3).Row
adres = Cells(r, sut).Value & aranan
a = InStr(Trim(adres), aranan)
For j = 1 To Len(adres)
i = InStr(j, adres, aranan, vbTextCompare)
If i > 0 Then
yer = WorksheetFunction.Trim(Mid(Cells(r, sut).Value, j, i - j))
 
For t = 1 To Len(yer)
If IsNumeric(Mid(yer, 1, t)) = False Then
Cells(sat, sut1 + 4).Value = WorksheetFunction.Trim(Mid(yer, t, Len(yer)))
Cells(sat, sut1 + 3).Value = WorksheetFunction.Trim(Mid(yer, 1, t - 1))
Exit For
End If
Next
If Cells(sat, sut1 + 3).Value = "" Then
Cells(sat, sut1 + 5).Value = 1
End If
sat = sat + 1
j = i
End If
Next
Next

Set j = CreateObject("Scripting.Dictionary")
s = sat1
For Each X In Range(Cells(sat1, sut1 + 4), Cells(Cells(Rows.Count, sut1 + 4).End(3).Row, sut1 + 4))
aranan1 = Replace(Replace(LCase(X.Value), "İ", "i"), "I", "ı")
If aranan1 <> "" Then
If Not j.exists(aranan1) Then
j.Add aranan1, Nothing

Cells(s, sut1).Value = X.Value
Cells(s, sut1 + 2).Value = WorksheetFunction.SumIf(Range(Cells(sat1, sut1 + 4), Cells(65000, sut1 + 4)), Cells(s, sut1).Value, Range(Cells(sat1, sut1 + 3), Cells(50, sut1 + 3)))
If Cells(s, sut1 + 2).Value = 0 Then
Cells(s, sut1 + 2).Value = ""
End If
Cells(s, sut1 + 1).Value = WorksheetFunction.SumIf(Range(Cells(sat1, sut1 + 4), Cells(50, sut1 + 4)), Cells(s, sut1).Value, Range(Cells(sat1, sut1 + 5), Cells(50, sut1 + 5)))
If Cells(s, sut1 + 1).Value = 0 Then
Cells(s, sut1 + 1).Value = ""
End If
s = s + 1
End If
End If
Next X
Columns(sut1 + 3).ClearContents
Columns(sut1 + 4).ClearContents
Columns(sut1 + 5).ClearContents
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub
Genişletmek için tıkla ...

Diğer mesajdan bir şey anlamamıştım. Açıkçası daha da sormaya çekindim. :)
Bu mesajınız iyi oldu. Allah razı olsun...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst