• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Veri Aktarımı

M

musaagac

Katılım
15 Haziran 2008
Mesajlar
286
Excel Vers. ve Dili
XP Office 2003
Arkadaşlar ekte göndermiş olduğum çalışmada pdf yi excel cevirmemden dolayı boşluklar oluşturuyor. Boşlukları silerek aktarmasını nasıl yapabilirim.
Çalışma ekte
 

Ekli dosyalar

Bul değiştir için bir makro yazsam olmadı çünkü data öyle bişi ki sanki içine girilip alt+enter yapılmış bir karakter yok.
 
ekteki çalışmada görüldüğü gibi işlemleri farklı alana aktarıyorum. aktarılken boşlukları silmesini istiyorum. aktarımı boşluklu yapıyor.
 
musaagac' Alıntı:
Arkadaşlar ekte göndermiş olduğum çalışmada pdf yi excel cevirmemden dolayı boşluklar oluşturuyor. Boşlukları silerek aktarmasını nasıl yapabilirim.
Çalışma ekte
Genişletmek için tıkla ...

Bu konunuzdada cevap vermezseniz bir dahaki sorularınıza ben bakmıyacağım.

kod:
Kod: 
Sub boslukal()
For i = 3 To Cells(Rows.Count, "a").End(3).Row
Cells(i, 1).Value = Replace(Cells(i, 1).Value, Chr(10), "")
Cells(i, 2).Value = Replace(Cells(i, 2).Value, Chr(10), "")
Cells(i, 3).Value = Replace(Cells(i, 3).Value, Chr(10), "") * 1
Cells(i, 3).NumberFormat = "General"
Next
End Sub

Not: Alıntı yazımı okuyun örnek dosyanızı buraya eklerken şifresiz eklemeye özen gösterin zira yazdığımız kodu nasıl deniyeceğiz.
 
Sub verileri_ayır() makrosunu çalıştır yaptığımda ilk önce Sub boslukal() makrosunu çalıştırmam için
Sub verileri_ayır() makrosunda boslukal makrosuna bağlandı nasıl yapılıyordu
 
musaagac' Alıntı:
Sub verileri_ayır() makrosunu çalıştır yaptığımda ilk önce Sub boslukal() makrosunu çalıştırmam için
Sub verileri_ayır() makrosunda boslukal makrosuna bağlandı nasıl yapılıyordu
Genişletmek için tıkla ...

Bunun bir çok yolu var mesela böyle olabilir.

kod:

Kod: 
Sub verileri_ayır()
boslukal
UserForm1.Show
Dim S1 As Worksheet, S2 As Worksheet
Dim SAT As Long, SAY As Long
Set S1 = Sheets("Ad-Soyad Bölme"): Set S2 = Sheets("Kurum Maaş")
Application.ScreenUpdating = False
S2.Range("B11:F11").ClearContents: SAY = 11
With WorksheetFunction
For SAT = 3 To S1.Cells(Rows.Count, "A").End(xlUp).Row
'S2.Cells(SAY, "A") = Mid(S1.Cells(SAT, "B"), 11, 4)
S2.Cells(SAY, "B") = Mid(S1.Cells(SAT, "B"), 15, 8)
S2.Cells(SAY, "C") = Mid(S1.Cells(SAT, "B"), 23, 4)
S2.Cells(SAY, "D") = S1.Cells(SAT, "C")
S2.Cells(SAY, "F") = Right(S1.Cells(SAT, "A"), Len(S1.Cells(SAT, "A")) - _
.Find("*", .Substitute(S1.Cells(SAT, "A"), " ", "*", Len(S1.Cells(SAT, "A")) _
- Len(.Substitute(S1.Cells(SAT, "A"), " ", "")))))
S2.Cells(SAY, "E") = Left(S1.Cells(SAT, "A"), Len(S1.Cells(SAT, "A")) - Len(S2.Cells(SAY, "F")) - 1)
SAY = SAY + 1
Next: End With
Application.ScreenUpdating = True
UserForm2.Show
Sheet1.Select
'MsgBox "Ad ve Soyad Ayrılmıştır...", vbInformation, "Musa AĞAÇ"
End Sub
 
Başka bir yaklaşımla modüldeki kodlarınız böyle olamalı ancak sayfa korumasını kaldırıp deneyin.

Kod: 
Option Explicit
Sub verileri_ayır()
UserForm1.Show
Dim S1 As Worksheet, S2 As Worksheet
Dim sat As Long, say As Long
Set S1 = Sheets("Ad-Soyad Bölme"): Set S2 = Sheets("Kurum Maaş")
Application.ScreenUpdating = False
Dim i
For i = 3 To Cells(Rows.Count, "a").End(3).Row
S1.Cells(i, 1).Value = Replace(S1.Cells(i, 1).Value, Chr(10), "")
S1.Cells(i, 2).Value = Replace(S1.Cells(i, 2).Value, Chr(10), "")
S1.Cells(i, 3).Value = Replace(S1.Cells(i, 3).Value, Chr(10), "") * 1
S1.Cells(i, 3).NumberFormat = "General"
Next

S2.Range("A11:G11").ClearContents: say = 11
For sat = 3 To S1.Cells(Rows.Count, "A").End(xlUp).Row
S2.Cells(say, "A") = say - 10
'S2.Cells(say, "A") = Mid(S1.Cells(sat, "B"), 11, 4)
S2.Cells(say, "B") = Mid(S1.Cells(sat, "B"), 15, 8) * 1
S2.Cells(say, "C") = Mid(S1.Cells(sat, "B"), 23, 4)
S2.Cells(say, "D") = S1.Cells(sat, "C")
S2.Cells(say, "E") = ADBUL(S1.Cells(sat, "A"))
S2.Cells(say, "F") = SOYADBUL(S1.Cells(sat, "A"))
S2.Cells(say, "g") = S2.Cells(7, "c")
say = say + 1
Next
Application.ScreenUpdating = True
UserForm2.Show
Sheet1.Select
'MsgBox "Ad ve Soyad Ayrılmıştır...", vbInformation, "Musa AĞAÇ"
End Sub
Sub boslukal()
Dim i
For i = 3 To Cells(Rows.Count, "a").End(3).Row
Cells(i, 1).Value = Replace(Cells(i, 1).Value, Chr(10), "")
Cells(i, 2).Value = Replace(Cells(i, 2).Value, Chr(10), "")
Cells(i, 3).Value = Replace(Cells(i, 3).Value, Chr(10), "") * 1
Cells(i, 3).NumberFormat = "General"
Next
End Sub
Function ADBUL(sayi)
Dim say, j
say = 0
sayi = WorksheetFunction.Trim(sayi)
For j = Len(sayi) To 1 Step -1
If Mid(sayi, j, 1) = " " Then
say = Mid(sayi, 1, j - 1)
Exit For
End If
Next j
ADBUL = WorksheetFunction.Proper(say)
If say = 0 Then
ADBUL = ""
End If
Exit Function
End Function

Function SOYADBUL(sayi)
Dim say, j, deg1, deg2, deg3
say = 0
sayi = WorksheetFunction.Trim(sayi)
For j = Len(sayi) To 1 Step -1
If Mid(sayi, j, 1) = " " Then
say = j + 1
Exit For
End If
Next j
If say > 0 Then
deg1 = Mid(sayi, say, Len(sayi))
deg2 = Replace(deg1, "i", "İ")
deg3 = Replace(deg2, "ı", "I")
SOYADBUL = deg3
Else
SOYADBUL = ""
End If
Exit Function
End Function


Sayfadaki kodlarda böyle olmalı

Kod: 
Private Sub CommandButton1_Click()
If IsEmpty(Worksheets(ActiveSheet.Name).Cells(2, 7).Value) Then
MsgBox "Lütfen kayıt edeceğiniz sürücüyü seçein"
GoTo son:
End If
If IsEmpty(Worksheets(ActiveSheet.Name).Cells(2, 3).Value) Then
MsgBox "Lütfen kurum kodunu doldurunuz"
GoTo son:
End If
If IsEmpty(Worksheets(ActiveSheet.Name).Cells(3, 2).Value) Then
MsgBox "Ödeme/tahsilat nedeni kodu bilgisini doldurunuz"
GoTo son
End If
If IsEmpty(Worksheets(ActiveSheet.Name).Cells(4, 2).Value) Then
MsgBox "Ödeme türünü doldurunuz"
GoTo son
End If
disketyaz
son:
End Sub
Sub disketyaz()
'sat = 11
sayac = 0
yer = Worksheets(ActiveSheet.Name).Cells(4, 3).Value
Kurummus = Worksheets(ActiveSheet.Name).Cells(2, 3).Value
Kurummus = LeftPadChar(Kurummus, "0", Worksheets(ActiveSheet.Name).Cells(2, 4).Value + Worksheets(ActiveSheet.Name).Cells(3, 4).Value) & " "
ODMTAHNDN = Worksheets(ActiveSheet.Name).Cells(3, 3).Value
ODMTAHNDN = LeftPadChar(ODMTAHNDN, "0", Worksheets(ActiveSheet.Name).Cells(3, 4).Value) & " "

dosyaad = Worksheets(ActiveSheet.Name).Cells(2, 7).Value & Kurummus & ODMTAHNDN & ".txt"
'dosyaad = ThisWorkbook.Path & "\" & Worksheets(ActiveSheet.Name).Cells(5, 3).Value & " " & Worksheets(ActiveSheet.Name).Cells(6, 3).Value & ".txt"

alan1 = Worksheets(ActiveSheet.Name).Cells(5, 8).Value
alan1 = LeftPadChar(alan1, "0", Worksheets(ActiveSheet.Name).Cells(5, 9).Value)
alan8 = Worksheets(ActiveSheet.Name).Cells(3, 8).Value
Open dosyaad For Output As #1

SabitKod = Worksheets(ActiveSheet.Name).Cells(4, 8).Value
SabitKod = RightPadChar(SabitKod, "0", Worksheets(ActiveSheet.Name).Cells(4, 9).Value)
Kurummus = Worksheets(ActiveSheet.Name).Cells(2, 3).Value
Kurummus = RightPadChar(Kurummus, "0", Worksheets(ActiveSheet.Name).Cells(2, 4).Value)
ODMTAHNDN = Worksheets(ActiveSheet.Name).Cells(3, 3).Value
ODMTAHNDN = LeftPadChar(ODMTAHNDN, "0", Worksheets(ActiveSheet.Name).Cells(3, 4).Value)
 
OdemeTarihi = Format(Cells(6, 3), "yyMMdd")
Kayitno = Worksheets(ActiveSheet.Name).Cells(5, 3).Value
Kayitno = LeftPadChar(Kayitno, "0", Worksheets(ActiveSheet.Name).Cells(5, 4).Value)
BordroNumarasi = Format(Cells(6, 3), "yyyymmdd")
BordroTarihi = Format(Cells(6, 3), "yyyymmdd")
 
OdemeKodu = Cells(4, 3)
Aciklama = Cells(7, 3)
deg = 0
Print #1, SabitKod & Kurummus & ODMTAHNDN & OdemeTarihi & Kayitno & BordroNumarasi & BordroTarihi & OdemeKodu & Aciklama
For sat = 11 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "E").End(3).Row
'While Not IsEmpty(Worksheets(ActiveSheet.Name).Cells(sat, 4).Value)
If Worksheets(ActiveSheet.Name).Cells(sat, 4).Value > 0 Then
alan2 = Worksheets(ActiveSheet.Name).Cells(Trim(Str(sat)), 2).Value
alan2 = LeftPadChar(alan2, "0", Worksheets(ActiveSheet.Name).Cells(2, 6).Value)
alan3 = Worksheets(ActiveSheet.Name).Cells(Trim(Str(sat)), 3).Value
alan3 = LeftPadChar(alan3, "0", Worksheets(ActiveSheet.Name).Cells(3, 6).Value)
alan4 = Format(Worksheets(ActiveSheet.Name).Cells(sat, 4).Value, "0.00")
alan4 = LeftPadChar(alan4, "0", Worksheets(ActiveSheet.Name).Cells(4, 6).Value)
alan5 = Worksheets(ActiveSheet.Name).Cells(Trim(Str(sat)), 5).Value
alan5 = RightPadChar(alan5, " ", Worksheets(ActiveSheet.Name).Cells(5, 6).Value)
alan6 = Worksheets(ActiveSheet.Name).Cells(Trim(Str(sat)), 6).Value
alan6 = RightPadChar(alan6, " ", Worksheets(ActiveSheet.Name).Cells(6, 6).Value)
alan7 = Worksheets(ActiveSheet.Name).Cells(Trim(Str(sat)), 7).Value
alan7 = RightPadChar(alan7, " ", Worksheets(ActiveSheet.Name).Cells(7, 6).Value)
'sat = sat + 1
Print #1, alan8 & alan1 & alan2 & alan3 & alan4 & alan5 & alan6 & alan7
sayac = sayac + 1
deg = deg + CDbl(Worksheets(ActiveSheet.Name).Cells(sat, 4).Value)
End If
'Wend
Next
SabitKod = Worksheets(ActiveSheet.Name).Cells(6, 8).Value
kisiSayisi = sayac 'Worksheets(ActiveSheet.Name).Cells(8, 3).Value
kisiSayisi = LeftPadChar(kisiSayisi, "0", Worksheets(ActiveSheet.Name).Cells(8, 4).Value)
'Miktar = Format(Worksheets(ActiveSheet.Name).Cells(9, 3).Value, "0.00")
Miktar = Format(deg, "0.00")
Miktar = LeftPadChar(Miktar, "0", Worksheets(ActiveSheet.Name).Cells(9, 4).Value)
Print #1, SabitKod & kisiSayisi & Miktar
MsgBox " Kurum disketi oluştu toplam " + Str(sayac) + " kişi bilgisi diskete aktarıldı"
Close #1
End Sub
Function RightPadChar(ByVal Astr As String, PadChar As String, stLen As Integer) As String
Dim AStrL As Integer
Astr = Trim(Astr)
AStrL = Len(Astr)
If AStrL < stLen Then
Astr = Astr + String(stLen - AStrL, PadChar)
Else
Astr = Mid$(Astr, 1, stLen)
End If
RightPadChar = Astr
End Function
Function LeftPadChar(ByVal Astr As String, PadChar As String, stLen As Integer) As String
Dim AStrL As Integer
Astr = Trim(Astr)
AStrL = Len(Astr)
If AStrL < stLen Then
Astr = String(stLen - AStrL, PadChar) + Astr
Else
Astr = Mid$(Astr, 1, stLen)
End If
LeftPadChar = Astr
End Function
 
Hocam Ekteki Çalışmada İlk satırda açıklama eklediğim yerin boyutu 100 karekter olmalı nasıl yapabilirim.

Şifreler 3872529
 

Ekli dosyalar

musaagac' Alıntı:
Hocam Ekteki Çalışmada İlk satırda açıklama eklediğim yerin boyutu 100 karekter olmalı nasıl yapabilirim.

Şifreler 3872529
Genişletmek için tıkla ...

Ben sorundan bir şey anlamadım açıklamayı nereye eklediniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst