VBA kodu hk

[üveyin]

merhabalar elimde mevcut kod yazılmış bir excel listem mevcut sizlerle paylaşacağım resimlerdeki mevcut kodun içine kırmızı ile işaretli satırları, kaydettiği csv dosyasında başlık olarak getirmesini istiyorum. bu konuda yardımcı olursanız sevinirim şimdiden teşekkürler.

 

[Korhan Ayhan]

Resim yerine kodu ve başlıkları içeren bir dosya paylaşmanız cevap almanızı hızlandıracaktır.

 

[üveyin]

ebatlama butonuna tıkladıgınızda kayıt yapılan dosyanın içinde resimde kırmızı ile işaretlediğim başlıkların olmasını istiyorum.
başlık yazan excelde alt tarafta olan yazıları kayıt yapılan dosyada başlık olarak isityorum, kod sayfa11 de şimdiden tşkler.

 

[Korhan Ayhan]

Başlıklarıda dosya olarak paylaşırmısınız?

 

[üveyin]

başlıklar

 

[Haluk]

Ekli örnek dosyadaki kodu inceleyip, kendinize uyarlayabilirsiniz umarım....

.

 

[üveyin]

Private Sub CommandButton1_Click()

cevap = MsgBox("Dosya farklı kaydedilecek emin misiniz ?", vbYesNo)
If cevap = vbYes Then

Dim i As Integer, j As Integer, myrng As Range, sira As Integer, filename As String


filename = ThisWorkbook.Path & "\KESIM-" & Format(Now, "ddmmyy-hhmmss") & ".csv"

Open filename For Output As #1

For i = 11 To 1000

If Range("B" & i).Value <> "" Then
sira = i - 10
ifade = Range("P" & i).Value & ";" & Range("S" & i).Value & ";" & Range("U" & i).Value & ";"
ifade = ifade & Range("BU" & i).Value & ";" & Range("B" & i).Value & ";" & Range("AI" & i).Value & ";" & Range("AK" & i).Value & ";"
ifade = ifade & Range("AM" & i).Value & ";" & Range("AO" & i).Value & ";" & Range("BM" & i).Value

' For j = 1 To myrng.Columns.Count
' lineText = IIf(j = 1, "", lineText & ";") & myrng.Cells(i, j)
' Next j

Print #1, ifade

End If
Next i

Close #1

MsgBox ("Csv Dosya kaydedildi.")
End If


renkli olan kodun olduğu kısma birşeyler yazarak bun yapmak istiyorum farklı formatta yeni bir dosya oluşturmak için değil tşk ederim

 

[üveyin]

Paylaştım

 

[Korhan Ayhan]

Deneyiniz.

Sayfa1'de K1:V2 aralığına başlık verilerinizi kopyaladım.

Private Sub CommandButton1_Click()
    cevap = MsgBox("Dosya farklı kaydedilecek emin misiniz ?", vbYesNo)
    If cevap = vbYes Then
 
        Dim i As Integer, j As Integer, myrng As Range
        Dim filename As String, fNum As Byte, Baslik As String
 
        fNum = FreeFile
     
        filename = ThisWorkbook.Path & "\KESIM-" & Format(Now, "ddmmyy-hhmmss") & ".csv"
     
        Open filename For Output As fNum
            Baslik = Join(Application.Transpose(Application.Transpose(Sheets("Sayfa1").Range("K1:V1").Value)), ";")
            Print #1, Baslik
            Baslik = Join(Application.Transpose(Application.Transpose(Sheets("Sayfa1").Range("K2:V2").Value)), ";")
            Print #1, Baslik
            
            For i = 11 To 1000
                If Range("B" & i).Value <> "" Then
                    If Range("BA" & i).Value <> 0 And Range("BE" & i).Value <> 0 Then
                        ifade = ifade & Range("G" & i).Value & ";" & Range("J" & i).Value & ";" & Range("L" & i).Value & ";"
                    Else
                        ifade = ifade & Range("P" & i).Value & ";" & Range("S" & i).Value & ";" & Range("U" & i).Value & ";"
                    End If
                    ifade = ifade & Range("BU" & i).Value & ";" & Range("B" & i).Value & ";" & Range("AI" & i).Value & ";" & Range("AK" & i).Value & ";"
                    ifade = ifade & Range("AM" & i).Value & ";" & Range("AO" & i).Value & ";" & Range("BM" & i).Value
                 
                    Print #1, ifade
                    ifade = ""
                End If
            Next i
        Close #1
     
        MsgBox ("Csv Dosya kaydedildi.")
    End If
End Sub

 

[üveyin]

tşk ederim istediğim başlıklar geliyor ama ekli dosyada kırmızı ile işaretlediğim kısımları fazla atıyor bunu çözebilirmiyiz nerede yanlış yapıyorum yada

 

[Korhan Ayhan]

Koda bir satır daha ekledim. Büyük ihtimalle sorun düzelecektir. Üstte ki mesajımdan son halini deneyiniz.

 

[üveyin]

Korhan bey çok tşk ederim istediğim oldu. bu dosya üzerinde bir daha rica etsem ebatlama butonuna basınca kesim sayfasındaki BA & BE hücreleri dolu olunca sutun G sutun J sutun L nundaki ölçüyü almasını istiyorum yardımlarınız için şimdiden tsk ederim. biliyorum çok oldun diyeceksiniz

 

[Korhan Ayhan]

Bahsettiğiniz sütunlar hangi sütunların yerine yazılacak?

 

[üveyin]

Korhan bey, yardımlarınız için şimdiden tşk ederim. ekli dosyada işaretlediğim sütünlar ebatlama butonuna tıklayınca gelmesini istiyorum. yani üst başlıkda yüzey yazan sütündaki bir deger varsa brüt sütünü yok ise bitmiş ölçü sütünundaki ölçülerin gelmesi gerekiyor.

 

[Korhan Ayhan]

Üstte ki mesajımda ki kodu revize ettim. Tekrar deneyiniz.

 

[üveyin]

Korhan bey, ilave sütün olmadan yüzey kaplaması varsa ölçü brüt sütündaki ölçüyü yüzey kaplaması yoksa bitmiş ölçü sütünundaki ölçüleri alsın istiyorum. biraz karmaşık ne istediğimi biliyorum ama anlatamadım galiba kusura bakmayın çok yardımcı oluyorsunuz tüm emeğiniz için şimdiden tşk ederim.

 

[Korhan Ayhan]

Tekrar revize ettim. Deneyiniz.

 

[üveyin]

BA & BE boş ise (P) (S) (U) hücresindeki değerleri alması gerekiyor, eger BA & BE dolu ise (G) (J) (L) hücresindeki değerleri alması gerekiyor.

 

[Korhan Ayhan]

Eklediğim koşul bahsettiğiniz işlemi yapıyor olması gerekir. Sorun mu var.

 

[üveyin]

BA & BE boş oldugu halde (G) (J) (L) hücresindeki değerleri alıyor halen.