iki makro kodun birleştirilmesi

[cengiz123]

merhabalar,

xml bir data var elimde. bu datayı excelin içine aktarıyorum. yalnız iki kodu peşpeşe birleştirdiğimden dolayı xml'yi iki sefer seç işlemi yapıyor.

tek seçme ve iki kodu aynı anda çalıştırma işlemi için nasıl bir değişiklik yapmak gerekir?

Dim deg1, k As Integer, a As String, sat As Long, sut As Integer
Dim deg2, m
Application.ScreenUpdating = False
Range("A1120000").Clear
sat = 2

dosya = Application.GetOpenFilename(FileFilter:="xml dosyalari,*.xml", Title:="xml dosyalari")
If dosya = False Then Exit Sub

Open (dosya) For Input As #1
Do While Not EOF(1)
Line Input #1, a
m = m + 1
If m > 1 Then
deg1 = Split(a, Chr(9))
sut = 1
For k = LBound(deg1) To UBound(deg1)
If k = 0 Then
deg2 = Split(deg1(k), " ")
For j = LBound(deg2) To UBound(deg2)
Cells(sat, sut).Value = deg2(j)
sut = sut + 1
Next
Else
Cells(sat, sut).Value = deg1(k)
sut = sut + 1
End If

Next
sat = sat + 1
End If
Loop
Close #1
Application.ScreenUpdating = True
'MsgBox "Islem tamamdir." & vbLf, vbOKOnly + vbInformation, "UYARI"

Application.DisplayAlerts = False
On Error Resume Next
'ThisWorkbook.Sheets("BOM").Delete
'On Error GoTo 0
Application.DisplayAlerts = True




Dim sImportFile As String, sFile As String
Dim sThisBk As Workbook
Dim vfilename As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sThisBk = ActiveWorkbook
sImportFile = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook")
If sImportFile = "False" Then
MsgBox "BOM Secilmedi!"
Exit Sub

Else
vfilename = Split(sImportFile, "\")
sFile = vfilename(UBound(vfilename))
Application.Workbooks.Open FileName:=sImportFile

Set wbBk = Workbooks(sFile)

With wbBk
Set wsSht = .sheets(1)
ActiveSheet.Name = "BOM"
wsSht.Copy after:=sThisBk.sheets(ThisWorkbook.Worksheets.Count)

wbBk.Close SaveChanges:=False
End With
End If
sheets("BOM").Range("A1:T300").Clear
sheets("BOM (2)").Select
Range("A1:T300").Copy
sheets("BOM").Select
Range("D1").PasteSpecial
Range("D1").Select
sheets("BOM (2)").Delete
sheets("Program").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[cengiz123]

arkadaşlar yardımcı olabilecek var mıdır?

 

[cengiz123]

merhabalar
yardımcı olabilecek var mıdır?

 

[cengiz123]

bu konuda destek olabilecek yokmudur?

 

[PLİNT]

Merhaba
Aşağıdaki gibi olabilir;

[SIZE="2"][COLOR="Blue"]'...Kod başlığınız[/COLOR]

 Dim deg1, k As Integer, a As String, sat As Long, sut As Integer
Dim deg2, m
Application.ScreenUpdating = False
Range("A1:d120000").Clear
sat = 2
dosya = Application.GetOpenFilename(FileFilter:="xml dosyalari,*.xml", Title:="xml dosyalari")
[COLOR="Red"]If dosya = False Then GoTo atla[/COLOR]
Open (dosya) For Input As #1
Do While Not EOF(1)
'.....
'.......
[COLOR="Blue"]'....kodlarınız[/COLOR]
'......
'ThisWorkbook.Sheets("BOM").Delete
'On Error GoTo 0
Application.DisplayAlerts = True
[COLOR="Red"]atla:
Call excel_ac[/COLOR]


End Sub[/SIZE]

Devamında çalışmasını istediğiniz kodları aşağıdaki gibi bir başlık altına alın

[SIZE="2"]Sub excel_ac()
Dim sImportFile As String, sFile As String
Dim sThisBk As Workbook
Dim vfilename As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sThisBk = ActiveWorkbook

'.....
[COLOR="Blue"]'.....kodlarınız[/COLOR]
'...
'....

End sub[/SIZE]

 

[cengiz123]

tam olarak böyle bir şey değil ama, bir yol kendim buldum. ilk sorguda dosya yolunu sorduktan sonra o dosya yolunu bir hücreye yazdırdım.
ikinci sorguyu yapmasın diye direk o hücreden yolu çektirdim. çalışıyor. bu şekilde