birleştir ve left kodlarıyla macro yazmak

[mersilen]

Selamlar

Yapmak istediğim CZ8 hücresine DA8: DI8 deki sayıları birleştirirken her sayıdan sonra 1 satırdaki DA1: DI1 deki kelimelerin ilk harflerini getirmek(sadece DD1 deki 2 harf gelecek--olmasada olur)

birşeyler yapmaya çalıştım ama olmadı

sat1=1
sat2=8

for sü to 9
 
  if sü=4  then x=2 else x=1   end if 
savunma1 = aplication.worksheetfunction.left(cell(sü;sat1);x)
 savunma2=cells(süt;sat2).value + savunma 1
savunma=savunma1 + savunma2

next sü

range("cz" & "sat2")=savunma

 

[Ömer]

Merhaba,

Bu şekilde deneyiniz.

Sub BirlestirYaz()

    Dim i As Byte, sayi As Byte

    Range("CZ8").ClearContents
    
    For i = 105 To 113
        sayi = 1
        If i = 108 Then sayi = 2
        Range("CZ8") = Range("CZ8") & Cells(8, i) & Left(Cells(1, i), sayi)
    Next i

End Sub

.

 

[mersilen]

Ömer hocam , hızır gibisiniz valla

çok teşekkürler

kodu biraz kendime göre değiştirdim

Sub BirlestirYaz()

Dim i As Byte, sayi As Byte
   Application.Calculation = xlManual
    Range("CZ8").ClearContents
    
    For i = 105 To 113
      If Cells(8, i).Value <> "" Then
        sayi = 1
        If i = 108 Then sayi = 2
        Range("CZ8") = Range("CZ8") & Cells(8, i) & Left(Cells(1, i), sayi)
      End If
    Next i
    Application.Calculation = xlAutomatic
End Sub

 

[mersilen]

Ömer hocam
tekrar merhaba

macroya satırları birer artırmak için bir döngü daha ekleyim dedim ama olmadı
hep ilk satırın sonucunu cz8:cz 18 e yazıyor
ayrıca clearcontents ide çalışmıyor

Sub BirlestirYaz()
Dim i As Byte, sayi As Byte
y = ""
Application.ScreenUpdating = False
Application.Calculation = xlManual
   
   [COLOR="Red"] For sat = 8 To 18[/COLOR]
      ' Range("CZ8").ClearContents
        [COLOR="Red"]Cells(sat, 104).ClearContents[/COLOR]
      For i = 105 To 113
        If Cells(sat, i).Value <> "" Then
          sayi = 1
          If i = 108 Then sayi = 2
           y = y & Cells(sat, i) & Left(Cells(1, i), sayi)
      
          End If
       Next i
       Cells(sat, 104) = y
    [COLOR="Red"]Next sat[/COLOR]
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub BİRLEŞTİR_LİSTELE()
    Dim X As Integer, Y As Byte
    
    Application.ScreenUpdating = False
    
    For X = 8 To 18
        Cells(X, 104).ClearContents
        For Y = 105 To 113
            Cells(X, 104) = Cells(X, 104) & Cells(X, Y) & IIf(Y = 108, Left(Cells(1, Y), 2), Left(Cells(1, Y), 1))
        Next
    Next
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Ömer]

Ömer hocam
tekrar merhaba

macroya satırları birer artırmak için bir döngü daha ekleyim dedim ama olmadı
hep ilk satırın sonucunu cz8:cz 18 e yazıyor
ayrıca clearcontents ide çalışmıyor

Bu şekilde deneyiniz.

Sub BirlestirYaz()

    Dim i As Byte, sayi As Byte, j As Byte
    
    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    Range("CZ8:CZ18").ClearContents
    
    For i = 8 To 18
      For j = 105 To 113
        If Cells(i, j) <> "" Then
          sayi = 1
          If j = 108 Then sayi = 2
         Cells(i, "CZ") = Cells(i, "CZ") & Cells(i, j) & Left(Cells(1, j), sayi)
        End If
      Next j
    Next i
    
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    
End Sub

.

 

[mersilen]

tekrar teşekkürler Ömer hocam