Сообщество Чайников

Вопрос

Имеется БД по клиентам (приход, расход, дата и т.д.), организованная в книгу с несколькими десятками листов. Ежедневно поступает новая информация по клиентам (сумма, дата, номер накладной). Как сделать макрос так, чтобы эта информация записывалась автоматически в карточку каждого клиента в следующие пустые ячейки, определяя нужного клиента по коду (наименованию)? Может существует решение такой проблемы, если на каждого клиента существует отдельный файл, имя которому — код клиента?

Ответ

Вот что у меня получилось, проверено в Excel2000 На всякий случай: комментарии относятся к нижележащей строке Этот текст нужно в редакторе Visual Basic (Alt+F11) вставить в пустой модуль (Insert — Module)

Option Explicit
'Здесь запишите адрес папки, в которой хранятся приходящие файлы по клиентам
Const MyFolder As String = "C:\" 'Количество полей (столбцов), в которые записывается информация Const FieldsCount As Integer = 5
'Имя файла, в котором хранится вся база
'Он должен быть в папке, отличной от MyFolder,
'иначе файл базы попадет в список клиентских
'что вызовет ошибку
Const MyBase As String = "C:Temp\base.xls" 'А это имя базы без пути
Const BaseName As String = "base.xls"
Sub WriteInfo()
Dim Files() As String, i As Integer, fs As FileSearch, strClient
As String, bOpened As Boolean
'Проверим, открыта ли база
For i = 1 To Application.Workbooks.Count
If Workbooks(i).Name = BaseName Then
bOpened = True
Exit For
End If
Next i
If bOpened = False Then Workbooks.Open MyBase
Set fs = Application.FileSearch
'Поиск пришедших файлов в папке
With fs
.LookIn = MyFolder
.FileName = "*.xls"
End With
'Получение имен файлов
If fs.Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
ReDim Files(1 To fs.FoundFiles.Count)
For i = 1 To fs.FoundFiles.Count
Files(i) = fs.FoundFiles(i)
Next i
Else
'Если в папке пусто, выполнение останавливается
'(Не забывайте очищать папку после каждого сеанса работы)
MsgBox "Новых файлов не найдено"
Exit Sub
End If
For i = 1 To UBound(Files)
'Получение имени листа откидыванием расширения от имени файла
strClient = Left$(Files(i), Len(Files(i)) — 4)
Workbooks.Open Files(i)
'(Предполагается, что в новых файлах только по одному листу,
'если это не так, пишите, сделаем по-другому)
'Также предполагается, что база заполняется, начиная с первого столбца
'(это первая единица в следующей строке)
Range(Cells(1, 1), Cells(1, 1).Offset(FirstEmptyCell — 2, FieldsCount — 1)).Select
Selection.Copy
Workbooks(BaseName).Activate
Worksheets(FileName(strClient)).Activate
Cells(FirstEmptyCell, 1).Activate
ActiveSheet.Paste
'Это делается для предотвращения появления сообщения
'о большом объеме информации в буфере обмена при закрытии файла
Cells(1, 1).Select
Selection.Copy
Workbooks(FileName(Files(i))).Close False
Next i
End Sub
'Функция нахождения первой пустой строки
Function FirstEmptyCell() As Long
'Это столбец, который будет проверяться на пустые ячейки
'Введите вместо единицы номер столбца,
'для которого в записях никогда не бывает пустых ячеек
Const Col As Integer = 1
Dim i As Long
For i = 1 To 65535
Cells(i, Col).Select
If ActiveCell.Value = "" Then
FirstEmptyCell = i
Exit Function
End If
Next i
End Function
'Получение имени файла из полного имени
Function FileName(FullName As String) As String
Dim i As Integer
For i = Len(FullName) To 1 Step -1
If Mid$(FullName, i, 1) = "\" Then
FileName = Mid$(FullName, i + 1)
Exit Function
End If
Next i
End Function

Alex Juice