Показаны сообщения с ярлыком Excel. Показать все сообщения
Показаны сообщения с ярлыком Excel. Показать все сообщения

7 нояб. 2013 г.

Перестановка колонок, выделение Ф.И.О из ФИО

Фокус еще в том, что исходный файл был DBF-ом, поэтому данные с 3 строки попадают в 1-ю в назначение (чтобы не трогать заголовки колонок)
Sub ConvertDBF()
    Sheets("DST").Columns("A:A").ColumnWidth = 3
    Sheets("DST").Columns("B:B").ColumnWidth = 5
    Sheets("DST").Columns("B:B").NumberFormat = "@"
    Sheets("DST").Columns("C:C").ColumnWidth = 5
    Sheets("DST").Columns("D:D").ColumnWidth = 6
    Sheets("DST").Columns("E:E").ColumnWidth = 8
    Sheets("DST").Columns("F:F").ColumnWidth = 23
    Sheets("DST").Columns("G:G").ColumnWidth = 23
    Sheets("DST").Columns("H:H").ColumnWidth = 23
    Sheets("DST").Columns("I:I").ColumnWidth = 21
    Sheets("DST").Columns("J:J").ColumnWidth = 12
    i = 3
    Do
        If Sheets("SRC").Cells(i, 5).Value = "" Then
            Exit Do
        End If
        Sheets("DST").Cells(i - 2, 1) = Sheets("SRC").Cells(i, 4)
        Sheets("DST").Cells(i - 2, 2) = "002"
        Sheets("DST").Cells(i - 2, 3) = "21"
        Sheets("DST").Cells(i - 2, 4) = Sheets("SRC").Cells(i, 6)
        Sheets("DST").Cells(i - 2, 5) = Sheets("SRC").Cells(i, 7)
        FIO = Trim(Sheets("SRC").Cells(i, 5))
        FirstSpacePos = InStr(1, FIO, " ", vbTextCompare)
        If FirstSpacePos > 0 Then
              Sheets("DST").Cells(i - 2, 6) = Left(FIO, FirstSpacePos - 1)
        End If
        SecondSpacePos = InStr(FirstSpacePos + 1, FIO, " ", vbTextCompare)
        If SecondSpacePos > 0 Then
              Sheets("DST").Cells(i - 2, 7) = Mid(FIO, FirstSpacePos + 1, SecondSpacePos - FirstSpacePos)
              Sheets("DST").Cells(i - 2, 8) = Mid(FIO, SecondSpacePos + 1)
        End If
        Sheets("DST").Cells(i - 2, 9) = Sheets("SRC").Cells(i, 14)
        Sheets("DST").Cells(i - 2, 10) = Sheets("SRC").Cells(i, 12)
    

        i = i + 1
    Loop
End Sub

1 авг. 2013 г.

Округление в выделенном диапазоне, Excel

Sub MyRoundRange()
    For Each cell In Selection
        cell.Value = WorksheetFunction.Round(cell.Value, 0)
    Next cell
End Sub

19 июн. 2013 г.

Вывод из Excel в файл

Любят бухгалтера все делать в Excel.А Диасофт 4х4 грузит из текстовых файлов.
Const BASE = 9000

Sub Макрос1()
    Dim fs, f
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.OpenTextFile("c:\clients.txt", 2, 8)

    i = 1
    Do
        If Cells(i, 1).Value = "" Then
            Exit Do
        End If
        f.WriteLine ("%КЛИЕНТ")
        f.WriteLine ("ИМЯ1      :" + Mid(Cells(i, 1).Value, 1, 40))
        f.WriteLine ("ИМЯ2      :" + Mid(Cells(i, 1).Value, 41, 40))
        f.WriteLine ("ИМЯ3      :" + Mid(Cells(i, 1).Value, 81, 40))
        f.WriteLine ("ИМЯ4      :" + Mid(Cells(i, 1).Value, 121, 40))
        f.WriteLine ("ТИП       :Ю")
        f.WriteLine ("АДРЕС1    :")
        f.WriteLine ("АДРЕС2    :")
        f.WriteLine ("ТЕЛЕФОН1  :")
        f.WriteLine ("ТЕЛЕФОН2  :")
        f.WriteLine ("КОД       :" + Trim(Str(i + BASE)))
        f.WriteLine ("ИНН       :" + Trim(Str(Cells(i, 2).Value)))
        f.WriteLine ("КПП       :" + Trim(Str(Cells(i, 3).Value)))
        f.WriteLine ("ГРУППА    :Юридические лица")
        f.WriteLine ("ДЕЙСТВИЕ  :Add")
        f.WriteLine ("%END")
        i = i + 1
    Loop
    f.Close
End

End Sub