Hucrelerdeki formulleri Makro ile yapma

[fatcem]

Merhabalar,

Elimde bir excel dosyası var ve bu excel dosyasıının sayfa 2 sinde formüller var,

Yapmak istediğim makroyu çalıştırdığımda formüllerin sonuçlarını yeni bir excel dosyasında farklı kaydetmek,

fomüller


A2 : =EĞER(Sayfa1!D2="";"";SAĞDAN(Sayfa1!D2;2)&"."&PARÇAAL(Sayfa1!D2;6;2)&"."&SOLDAN(Sayfa1!D2;4))
B2 : =EĞER(Sayfa1!A2="";"";Sayfa1!A2)
C2 : =EĞER(Sayfa1!P2="ICHAT";"I";EĞER(Sayfa1!P2="DISHAT";"D";""))
D2 : =EĞER(Sayfa1!B2="";"";PARÇAAL(Sayfa1!B2;4;10))
E2 : =EĞER(Sayfa1!H2="";"";Sayfa1!H2)
F2 : =EĞER(Sayfa1!I2="";"";TOPLA(Sayfa1!I2-Sayfa1!W2))
G2 : =EĞER(Sayfa1!W2="";"";Sayfa1!W2)
H2 : =EĞER(Sayfa1!J2="";"";Sayfa1!J2)
K2 : =EĞER(Sayfa1!A2="";"";"CC")
L2 : =EĞER(Sayfa1!O2="";"";Sayfa1!O2)
O2 : =EĞER(Sayfa1!Q2="";"";SOLDAN(Sayfa1!Q2;3))
P2 : =EĞER(Sayfa1!Q2="";"";PARÇAAL(Sayfa1!Q2;5;3))
Q2 : =EĞER(Sayfa1!Q2="";"";PARÇAAL(Sayfa1!Q2;9;3))
R2 : =EĞER(Sayfa1!Q2="";"";PARÇAAL(Sayfa1!Q2;13;3))
S2 : =EĞER(Sayfa1!Q2="";"";PARÇAAL(Sayfa1!Q2;17;3))
T2 : =EĞER(Sayfa1!A2="";"";"Q")
X2 : =EĞER(Sayfa1!S2="";"";SAĞDAN(Sayfa1!S2;2)&"."&PARÇAAL(Sayfa1!S2;6;2)&"."&SOLDAN(Sayfa1!S2;4))
AN2: =EĞER(Sayfa1!A2="";"";"TK")

Formüller tüm satırlar için geçerli olacak.



İlginiz için şimdiden teşekkürler...

 

[Emir Hüseyin Çoban]

Sayfa2 den ornek dosya yukleyin.
Bu islem icin sayfa yapisini bilmek gerek. Birlestirilmis hucre vs. varsa kodlamayi etkiler.

.

 

[fatcem]

Sayfa2 den ornek dosya yukleyin.
Bu islem icin sayfa yapisini bilmek gerek. Birlestirilmis hucre vs. varsa kodlamayi etkiler.

.

Emir Bey merhaba ben dosyayı yukledim dosyadan da gorebileciğiniz gibi 1 adet de makro çalıştırıyorum, amacım daha önce de bahsettiğim gibi var olan tüm formuller ve makroları birleştirip tek makroyu çalıştırdığmda sayfa 2 deki iligili yerlerde ilgili bilgilerin olduğu ve bu sayfanın başka bir macrosuz xls olarak kaydettirmek istiyorum,

İlginiz için teşekkürler...


http://www.dosya.tc/server7/5n7cf1/RAPOR_AKTARIM_Makrolu.rar.html

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    yol = ThisWorkbook.Path & "\Yeni_" & Format(Now, "ddmmyyyyhhmmss") & ".xls"
    Sheets("Sayfa2").Select
    Cells.Copy
    Workbooks.Add
    Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    
    Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    
    Application.CutCopyMode = False
    
    ActiveWorkbook.SaveAs Filename:=yol, _
    FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
    ReadOnlyRecommended:=False, CreateBackup:=False
    
    ActiveWindow.Close
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "B i t t i"
End Sub

. . .

 

[fatcem]

. . .

Sub KOD()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    yol = ThisWorkbook.Path & "\Yeni_" & Format(Now, "ddmmyyyyhhmmss") & ".xls"
    Sheets("Sayfa2").Select
    Cells.Copy
    Workbooks.Add
    Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    
    Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    
    Application.CutCopyMode = False
    
    ActiveWorkbook.SaveAs Filename:=yol, _
    FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
    ReadOnlyRecommended:=False, CreateBackup:=False
    
    ActiveWindow.Close
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "B i t t i"
End Sub

. . .

Çok teşekkürler ellerinize sağlık...

Ben size xls deyince sizde doğal olarak öle formüllediniz son olarak

Dosyayı C:\Pegasus\THY\ yoluna o günün tarihi ve xlsx olarak kaydettirebilirmiyiz.

 

[Emir Hüseyin Çoban]

. . .

Saat Dakika kısmını kaldırmak için yol kısmından hhmmss kısımlarını silebilirsiniz.
Kodlar aynı gün birden fazla çalıştırdığında çakışma olmaması için saatdakika bilgilerini kullandım.

Sub KOD()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    yol = "C:\Pegasus\THY" & "\Yeni_" & Format(Now, "ddmmyyyy hhmmss") & ".xlsx"
    
    Sheets("Sayfa2").Select
    Cells.Copy
    Workbooks.Add
    Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    
    Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    
    Application.CutCopyMode = False
    
    ActiveWorkbook.SaveAs Filename:=yol, _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    
    ActiveWindow.Close
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "B i t t i"
    
End Sub

. . .

 

[fatcem]

. . .

Saat Dakika kısmını kaldırmak için yol kısmından hhmmss kısımlarını silebilirsiniz.
Kodlar aynı gün birden fazla çalıştırdığında çakışma olmaması için saatdakika bilgilerini kullandım.

Sub KOD()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    yol = "C:\Pegasus\THY" & "\Yeni_" & Format(Now, "ddmmyyyy hhmmss") & ".xlsx"
    
    Sheets("Sayfa2").Select
    Cells.Copy
    Workbooks.Add
    Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    
    Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    
    Application.CutCopyMode = False
    
    ActiveWorkbook.SaveAs Filename:=yol, _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    
    ActiveWindow.Close
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "B i t t i"
    
End Sub

. . .

Ellerinize sağlık, Çok teşekkürler, Allah razı olsun...