Developing.ru

Код: Выделить всё

Sub Макрос1()
Const sE$ = " "
Dim xlDBF As Object, xl As Object, i&, j&, s$
Set xl = ActiveWorkbook.Worksheets(1) '
Set xlDBF = Workbooks.Open(Filename:="C:\A6.DBF")
    i = 2
    With xlDBF.ActiveSheet
        s = .Cells(i, 6):
        Do
            j = InStr(1, s, sE, 1)
            If j > 0 Then s = Left(s, j - 1)
            s = s & sE & .Cells(i, 20) & sE & .Cells(i, 21)
            xl.Cells(22 + i, 2) = s
            xl.Cells(22 + i, 1) = .Cells(i, 3)
            xl.Cells(22 + i, 3) = .Cells(i, 19)
            xl.Cells(22 + i, 4) = .Cells(i, 18)
            i = i + 1
            s = .Cells(i, 6):
        Loop Until Len(s) = 0
    End With
xlDBF.Close
Set xlDBF = Nothing
...
End Sub

Код: Выделить всё

 Sub FindDBF() 'поиск файла дбф
Dim FilePath, DBFName As String, ko As Integer
On Error GoTo errr
'отключаем обновление экрана, чтоб быстрее работало
Application.ScreenUpdating = False
'задаем путь к файлам
FilePath = Range("Сервис!Y1").Value
'ищем файлы с расширением dbf по указанному выше пути
DBFName = Dir(FilePath & "*.dbf")
'если ни один файл не найден завершаем процедуру
If DBFName = "" Then GoTo errr
ko = 1
Call copy_r(FilePath, DBFName, ko)


'в цикле ищем файлы
Do While DBFName <> ""

'получаем имя очередного файла
DBFName = Dir

If DBFName = "" Then Exit Do 'если файл не найден завершаем цикл
    
Call copy_r(FilePath, DBFName, ko)

If ko > 2 Or ko = 2 Then
MsgBox ("В папке " & UserForm1.TextBox3 & vbNewLine & vbNewLine & _
"найдено больше одного DBF файла с данными," & vbNewLine _
& "поэтому автоматическое заполнение невозможно! " & vbNewLine _
& "Выполните выбор файла вручную."), vbExclamation, "Уточните имя нужного файла"
new_r
manualopenDBF ' макрос ручного выбора файла
GoTo exx
End If

Loop

exx:
'включаем обновление экрана
Application.ScreenUpdating = True

Exit Sub
errr:
MsgBox ("Не найдено ни одного файла dbf! Проверьте правильность заданного пути к папке с файлами dbf!"), vbCritical, "Не найдены файлы"

End Sub 

Код: Выделить всё

 Function copy_r(FilePath, DBFName, ko) 'обработка файлов
Dim y, sm, m, nsm As Integer
Dim lic, fam, imja, otch, sum, nom As Integer
Dim fio, fiosc, schet, schetsc, tem, temsc, temf As String
ko = 1
'открываем найденный файл
Workbooks.Open (FilePath & DBFName)
If Range("F2").Value <> "" Then 'если файл не пустой

' мне приносили два варианта дбф файлов. поэтому проверяем какому соответствует:
' каждый обрабатываемый столбец, на всякий случай
If Range("A1").Value = "NOMPP" And ....
 Then
nom = 1
fam = 5
imja = 6       ' номера столбцов с нужными данными согласно первому варианту
otch = 7
lic = 2
sum = 3
GoTo obrab
End If

' второй вариант структуры дбф файла
If...Then
...
Else
Workbooks(DBFName).Close
Exit Function
End If

obrab:
ko = ko + 1
DBFName = ActiveWorkbook.name

'определяем количество строк в dbf файле
y = Cells.SpecialCells(xlCellTypeLastCell).Row

'активизируем эту книгу
ThisWorkbook.Sheets("Реестр").Activate

'смещение вниз для вставляемых строк
sm = 22
m = 25

' в цикле копируем данные из dbf в активный лист этой книги
For n = 2 To y
nsm = n + sm

'добавляем строку, форматируем
m = m + 1
Cells(m, 1).EntireRow.Insert
Cells(nsm, 5).NumberFormat = "@"
Cells(nsm, 6).NumberFormat = "@"
Cells(nsm, 7).NumberFormat = "#,##0.00"

For nst = 4 To 8
With Cells(nsm, nst).Borders
       .LineStyle = xlContinuous
       .Weight = xlThin
       .ColorIndex = xlAutomatic
End With
Next

'данные из столбца dbf вставляем в столбец xls
ThisWorkbook.Sheets("Реестр").Cells(nsm, 4).Value = Workbooks(DBFName).ActiveSheet.Cells(n, nom).Value

wd = Split(Workbooks(DBFName).ActiveSheet.Cells(n, fam).Value, " ")

'ставим фамилию, имя, отч в ячейку
On Error Resume Next
fio = wd(0) & " " _
& Workbooks(DBFName).ActiveSheet.Cells(n, imja).Value & " " _
& Workbooks(DBFName).ActiveSheet.Cells(n, otch).Value
ThisWorkbook.Sheets("Реестр").Cells(nsm, 5).Value = fio

'ставим лиц счет....
.........
   Next
End If
........
'закрываем дбф файл
Workbooks(DBFName).Close
......
End Function