Преобразовать один файл в другой по требованию

[Hugo121]

Поменяйте так:
If FName <> "False" Then
либо уберите тип:
Dim FName

не знаю, дома работало...

[valerij]

Сообщение от Hugo121

Поменяйте так:
If FName <> "False" Then

Так, работает, вечером все проверю, отпишусь

[valerij]

Hugo121
А как сделать, что бы не создавать новую книгу, а копировалось там, где и макрос.
Дело в том, что книга, куда все преобразовывается, имеет др. имя и идет в связке с другой, а так мне придется каждый раз, переименовывать

[Hugo121]

Тогда последние 5 строчек кода должны быть такими:

    With ThisWorkbook.Sheets(1)
        .Range(.Cells(1, 1), .Cells(UBound(a), 4)).Value = a
       .Columns(3).Delete Shift:=xlToLeft
    End With
End Sub

И кстати в версии с новой книгой правильнее так:

    With Workbooks.Add.Sheets(1)
        .Range(.Cells(1, 1), .Cells(UBound(a), 4)).Value = a
       .Columns(3).Delete Shift:=xlToLeft
    End With
End Sub

[valerij]

Сообщение от Hugo121

Тогда последние 5 строчек кода...

Во, супер!!!
И еще последний ? и перейдем ко второй части, сам не смогу.
Я добавил в конце макроса, код, что бы закрывался автоматом

Windows("1.xls").Activate
    ActiveWindow.Close
End Sub

Но, имя файла, оригинала, может быть какое угодно, как в голову заводу стукнет...
Нельзя ли, в макросе, не прописывать имя("1.xls")??

[Hugo121]

Тогда конец такой (впрочем, Dim можно в начало перенести):

    With Workbooks.Add.Sheets(1) 'ThisWorkbook.Sheets(1) '
        .Range(.Cells(1, 1), .Cells(UBound(a), 4)).Value = a
       .Columns(3).Delete Shift:=xlToLeft
    End With
    
Dim spth As String
    spth = Dir(FName, vbDirectory)
    Windows(spth).Close

End Sub

Или короче

Windows(Dir(FName, vbDirectory)).Close

[valerij]

Сообщение от Hugo121

Или короче

Все, отлично!!!
2-я часть ?
У меня часто бывает, что два, разных по имени, файла оригинала и втулить их надо в один, как выше ты сделал, только второй, под первым, в те же столбцы, только через одну, пустую строчку, скрин!

[Hugo121]

Ну так тут особо ничего переделывать не надо - ставим открытие и весь код в цикл, а выгрузку не в Cells(1,1), а в Cells(переменная,1). Ну а переменной добавляем в цикле UBound(a).
Сам или я вечером? Сейчас уже убегаю.
Да, а выход из цикла будет и так после отказа открывать очередной файл.

[valerij]

Сообщение от Hugo121

Сам или я вечером?

Не получилось, стирается инфа столбца "С", первого оригинала

Dim otkr As Byte, dov As Long
For otkr = 0 To 1
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls")
хххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххххх
For i = 1 To UBound(a)
                    If a(i, 4) <> "" Then
                        a(i, 2) = Split(a(i, 2))(5)
                    Else
                        a(i, 2) = 0
                    End If
                Next
                    If otkr = 1 Then
                        dov = UBound(a)
                    Else
                        dov = 0
                    End If
With ThisWorkbook.Sheets(1)
        .Range(.Cells(1 + dov, 1), .Cells(dov + UBound(a), 4)).Value = a

Ваще все не правильно сделал, бред, не въеду, как!

[Hugo121]

Про "стирается" я забыл сказать - там из-за объединённых ячеек я третий столбец в конце удалял. Надо это дело из цикла вынести в конец.
В общем код такой, на два захода, вставляем в эту книгу (с новой там надо тогда флаг что ли ставить, сложнее будет):

Option Explicit

Sub importdata()
    Dim FName As String
    Dim x As Range
    Dim i As Long, strow As Long, endrow As Long
    Dim a
    Dim raz As Byte
    Dim dov As Long
    dov = 1
For raz = 0 To 1
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls")
    If FName <> "False" Then
        With Workbooks.Open(FName)
            With .Sheets(1)

                Set x = .Cells.Find("Сальдо начальное", lookAt:=xlPart)
                If Not x Is Nothing Then
                    strow = x.Row
                Else
                    Exit Sub
                End If

                Set x = .Cells.Find("Обороты за период", lookAt:=xlPart)
                If Not x Is Nothing Then
                    endrow = x.Row
                Else
                    Exit Sub
                End If

                a = Range(.Cells(strow + 1, 2), .Cells(endrow - 1, 5)).Value
                For i = 1 To UBound(a)
                    If a(i, 4) <> "" Then
                        a(i, 2) = Split(a(i, 2))(5)
                    Else
                        a(i, 2) = 0
                    End If
                Next
            End With
        End With
    Else
        Exit Sub
    End If
    
    With ThisWorkbook.Sheets(1) 'Workbooks.Add.Sheets(1) 'это тут не годится
        .Range(.Cells(dov, 1), .Cells(dov + UBound(a) - 1, 4)).Value = a
      ' .Columns(3).Delete Shift:=xlToLeft'это выносим из цикла
    End With
    dov = dov + UBound(a) + 1
    Windows(Dir(FName, vbDirectory)).Close
Next

       ThisWorkbook.Sheets(1).Columns(3).Delete Shift:=xlToLeft

End Sub