DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Excel_Dosyasını_XLM_Dosyasına_Çevirme()
Dim Satır As Integer, Sütun As Integer, Temp As String, YesNo As Variant, yol As String
Dim Dosya_Adı As String, Başlıklar As String, Alt As String, Alan As Integer
Dim Ilk_Hücre As String, Ikinci_Hücre As String, Sütun_Adı(99) As String
Alt = Chr(10) & Chr(13)
yol = ThisWorkbook.Path & "\"
YesNo = MsgBox("Bu işlem için aşağıdaki veriler gerekli:" & Alt _
& "Dosya Adını Girin" & Alt _
& "Kayıt İçin Grup Adı Girin" & Alt _
& "Başlıkların Bulunduğu Hücre Aralığını Girin" & Alt _
& "Tablonun Hücre Aralığını Girin" & Alt _
& "Devam Etmek İçin Hazır mısınız ?", vbQuestion + vbYesNo, "Www.ExcelVBA.Net")
If YesNo = vbNo Then
Debug.Print "Kullanıcı Hayır diyerek iptal etti."
Exit Sub
End If
Dosya_Adı = Alanları_Doldur(InputBox("Dosya Adını Girin:", "Www.ExcelVBA.Net", "XML DOSYASI"))
If Right(Dosya_Adı, 4) <> ".xml" Then
Dosya_Adı = Dosya_Adı & ".xml"
End If
Başlıklar = Alanları_Doldur(InputBox("Kayıt İçin Grup Adı Girin", "Www.ExcelVBA.Net", "Group"))
Ilk_Hücre = InputBox("Başlıkların Bulunduğu Hücre Aralığını Girin:", "Www.ExcelVBA.Net", "A1:D1")
If Hücrem(Ilk_Hücre, 1) <> Hücrem(Ilk_Hücre, 2) Then
MsgBox "Hata: İsimler tek bir satırda olmalı" & Alt & "İşlem Durdu", vbOKOnly + vbCritical, "Www.ExcelVBA.Net"
Exit Sub
End If
Satır = Hücrem(Ilk_Hücre, 1)
For Sütun = Hücrem(Ilk_Hücre, 3) To Hücrem(Ilk_Hücre, 4)
If Len(Cells(Satır, Sütun).Value) = 0 Then
MsgBox "Hata: Başlıkta boş hücre içeriyor, bunun olmaması gerek." & Alt & "İşlem Durdu", vbOKOnly + vbCritical, "Www.ExcelVBA.Net"
Exit Sub
End If
Sütun_Adı(Sütun - Hücrem(Ilk_Hücre, 3)) = Alanları_Doldur(Cells(Satır, Sütun).Value)
Next Sütun
Ikinci_Hücre = InputBox("Tablonun Hücre Aralığını Girin", "Www.ExcelVBA.Net", "A2:D4")
If Hücrem(Ilk_Hücre, 4) - Hücrem(Ilk_Hücre, 3) <> Hücrem(Ikinci_Hücre, 4) - Hücrem(Ikinci_Hücre, 3) Then
MsgBox "Alan adları sayısı veri sütunlarına eşit değil" & Alt & "İşlem Durdu", vbOKOnly + vbCritical, "Www.ExcelVBA.Net"
Exit Sub
End If
Alan = Hücrem(Ikinci_Hücre, 3)
If InStr(1, Dosya_Adı, ":\") = 0 Then
Dosya_Adı = yol & Dosya_Adı
End If
Open Dosya_Adı For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "ISO-8859-1" & Chr(34) & "?>"
Print #1, "<Www.ExcelVBA.Net>"
For Satır = Hücrem(Ikinci_Hücre, 1) To Hücrem(Ikinci_Hücre, 2)
Print #1, "<" & Başlıklar & ">"
For Sütun = Alan To Hücrem(Ikinci_Hücre, 4)
Print #1, "<" & Sütun_Adı(Sütun - Alan) & ">" & Işaret_Değiştir(Formatlar(Satır, Sütun)) & "</" & Sütun_Adı(Sütun - Alan) & ">"
Next Sütun
Print #1, "</" & Başlıklar & ">"
Next Satır
Print #1, "</Www.ExcelVBA.Net>"
Close #1
MsgBox Dosya_Adı & " oluşturuldu." & Alt & "İşlem Tamamlandı.", vbOKOnly + vbInformation, "Www.ExcelVBA.Net"
Debug.Print Dosya_Adı & " Kaydedildi."
End Sub
Function Hücrem(Aralık As String, Değer As Integer) As Integer
Dim Hücre As Range
Set Hücre = Range(Aralık)
Select Case Değer
Case 1
Hücrem = Hücre.Row
Case 2
Hücrem = Hücre.Row + Hücre.Rows.Count - 1
Case 3
Hücrem = Hücre.Column
Case 4
Hücrem = Hücre.Columns(Hücre.Columns.Count).Column
End Select
Exit Function
End Function
Function Alanları_Doldur(Karakter As String) As String
'Boşluğu kaldır ve _ alt çizgi karakteriyle değeiştir'
Dim Ayır As Integer
Ayır = InStr(1, Karakter, " ")
Do While Ayır > 0
Mid(Karakter, Ayır, 1) = "_"
Ayır = InStr(1, Karakter, " ")
Loop
Alanları_Doldur = LCase(Karakter)
End Function
Function Formatlar(Sat As Integer, Sut As Integer) As String
'Formatları Ayarla
Formatlar = Cells(Sat, Sut).Value
If IsNumeric(Cells(Sat, Sut).Value) Then
Formatlar = Format(Cells(Sat, Sut).Value, "#,##0 ;(#,##0)")
End If
If IsDate(Cells(Sat, Sut).Value) Then
Formatlar = Format(Cells(Sat, Sut).Value, "dd.mm.yyyy")
End If
End Function
Function Işaret_Değiştir(Karakter As String) As String
' (&) sembolünü (+) sembolü ile değiştir'
Dim Ayır As Integer
Ayır = InStr(1, Karakter, "&")
Do While Ayır > 0
Mid(Karakter, Ayır, 1) = "+"
Ayır = InStr(1, Karakter, "&")
Loop
Işaret_Değiştir = Karakter
End Function