макрос

[alibek]

elena, лучше выложи в форум 2-3 файла Excel, с которых будут извлекаться данных, и пример заполненного файла Word, который требуется получить.

[elena]

elena, лучше выложи в форум 2-3 файла Excel, с которых будут извлекаться данных, и пример заполненного файла Word, который требуется получить.

- Файл не в Word, он у меня в Excel.
примерчик вот он.

[Igor_123]

А если там будет лежать четвертый файл lieferant_N.xls
с данными:

MCS005001A N MULTI-SCHAUM 5,00 0,350 84314980
MCS005002A N SCHNELLREINIGER UN 5,00 0,450 84314980
MCS005003A N MULTIFUNKTIONSSPRA 5,00 0,450 84314980

Каков должен быть результат?

[elena]

А если там будет лежать четвертый файл lieferant_N.xls
с данными:

MCS005001A N MULTI-SCHAUM 5,00 0,350 84314980
MCS005002A N SCHNELLREINIGER UN 5,00 0,450 84314980
MCS005003A N MULTIFUNKTIONSSPRA 5,00 0,450 84314980

Каков должен быть результат?

здраствуйте,
тогда данные четвертого нужно перенять.

[alibek]

То есть, надо пройтись по всем файлам lieferant_*.xls и выгрузить только те записи, которые есть в каждом файле? Так?

[Igor_123]

то есть в результате должно быть...
Нет! Каково правило составления результирующего набора данных:
1 - при равенстве данных в столбце Один смотрим столбец Два.
2 - Если в столбце Два данные не одинаковы, то в результат попадет запись отобранная по (какому???) критерию.
3 - Если в столбце Два данные одинаковы, то (что делаем???)

Огласите пожалуйста весь список! (с) "Операция Ы и другие приключения Шурика"

[elena]

То есть, надо пройтись по всем файлам lieferant_*.xls и выгрузить только те записи, которые есть в каждом файле? Так?

думаю что да

[Ramzes]

То есть, надо пройтись по всем файлам lieferant_*.xls и выгрузить только те записи, которые есть в каждом файле? Так?

думаю что да

[alibek]

Не совсем понял, что именно требуется, но попробуй этот код:

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

Sub ExportData()
Dim P As String, F As String, R As Long, C As String, I As Long
Dim wb As Workbook, sh As Worksheet, Cell As Range
Dim Data() As String, DC As Long, fFirst As Boolean
ReDim Data(1 To 6, 0)
fFirst = True
DC = 0
P = "C:\"
F = Dir$(P & "lieferant_*.xls")
Do Until Len(F) = 0
  Set wb = Workbooks.Open(P & F)
  Set sh = wb.Sheets(1)
  If fFirst Then
    R = 1
    Do
      R = R + 1
      C = sh.Cells(R, 1).Text
      If Len(C) = 0 Then Exit Do
      DC = DC + 1
      If DC > UBound(Data, 2) Then ReDim Preserve Data(1 To 6, 0 To UBound(Data, 2) + 100)
      For I = 1 To 6
        Data(I, DC) = sh.Cells(R, I)
      Next I
    Loop
    ReDim Preserve Data(1 To 6, 0 To DC)
    fFirst = False
  Else
    For R = DC To 1 Step -1
      Set Cell = sh.Cells.Find(What:=Data(1, R), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
      If Cell Is Nothing Then
        If R < DC Then
          For I = R + 1 To DC
            Data(1, I - 1) = Data(1, I)
            Data(2, I - 1) = Data(2, I)
            Data(3, I - 1) = Data(3, I)
            Data(4, I - 1) = Data(4, I)
            Data(5, I - 1) = Data(5, I)
            Data(6, I - 1) = Data(6, I)
          Next I
        End If
        DC = DC - 1
        ReDim Preserve Data(1 To 6, 0 To DC)
      Else
        For I = 1 To 6
          Data(I, R) = Cell.Offset(0, I - 1).Text
        Next I
      End If
    Next R
  End If
  wb.Close False
  Set wb = Nothing
  F = Dir$()
Loop
Set wb = Workbooks.Add
Set sh = wb.Sheets(1)
For R = 1 To DC
  For I = 1 To 6
    sh.Cells(R, I) = Data(I, R)
  Next I
Next R
End Sub

Для него не обязательно создавать книгу.
Создаешь макрос, вставляешь код, указываешь свой путь (в строке P="C:\"), запускаешь.
Макрос обходит все lieferant-файлы, с первого копирует все данные, которые остануться только, если эти данные есть во всех остальных файлах. При этом информация в строках будет соответствовать последнему файлу.

[elena]

[quote="Igor_123"]то есть в результате должно быть...
Нет! Каково правило составления результирующего набора данных:

1 - при равенстве данных в столбце Один смотрим столбец Два.-
-Да! И стольбец четыре.

2 - Если в столбце Два данные не одинаковы, то в результат попадет запись отобранная по (какому???) критерию.
если номер есть в L то его нужно заменить на похожий но только с буквой "M",или "N".

3 - Если в столбце Два данные одинаковы, то (что делаем???)
- то заменяем данные новыми из книги lieferant "M",или "N".

[elena]

Для него не обязательно создавать книгу.
Создаешь макрос, вставляешь код, указываешь свой путь (в строке P="C:"), запускаешь.
Макрос обходит все lieferant-файлы, с первого копирует все данные, которые остануться только, если эти данные есть во всех остальных файлах. При этом информация в строках будет соответствовать последнему файлу.

а можно еще вопрос вам задать ? при срабатывании макроса у меня открывается новая книга. это что означает?
я что то не так делаю ?

[alibek]

Новая и должна открываться, в нее записываются результаты (в шесть колонок).

[elena]

Новая и должна открываться, в нее записываются результаты (в шесть колонок).

попробую еще раз. а вот если данных больще чем в указаном примере. то будет ли работать макрос? или нужно что то исправлять ?

[alibek]

Макрос будет работать, если во всех файлах будет хотя бы один одинаковый код. По крайней мере, именно так я понял, что требуется от макроса.

[elena]

Макрос будет работать, если во всех файлах будет хотя бы один одинаковый код. По крайней мере, именно так я понял, что требуется от макроса.

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

[elena]

[quote="alibek"] отзовитесь, макрос открывает пустую книгу.

[alibek]

elena, я не понимаю, что нужно сделать и в чем состоит задача, поэтому ничего не могу подсказать.

Немного переделал макрос, возможно, на этот раз я угадал, что требуется от программы.

Как использовать:
1. Создать новую (пустую) книгу.
2. Открыть редактор VBA.
3. Добавить в книгу новый модуль.
4. Вставить следующий код.


В коде есть три места (помеченные *** START POINT N *** ... *** END POINT N ***), эти места необходимо подредактировать под свои потребности.
В первой точке (POINT 1) задается папка, в которой располагаются файлы (у меня это C:\), ее нужно заменить на свою.
Вторую точку нужно раскомментировать, если требуется добавление отсутствующих в предыдущих файлах данных.
Третью точку нужно закомментировать, если не требуется удаление отсутствующих в предыдущих файлах данных.

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

Option Explicit

Private Type DataType
  Sachnummer As String
  Lieferant As String
  Bezeichnung As String
  Verkaufspreis As Variant
  Gewicht As Variant
  Zolltarifnummer As Variant
End Type

Private Sub SortArrayString(aData() As String)
Dim I0 As Long, I As Long, P As Long, V As String
For I0 = 1 To UBound(aData) - 1
  P = I0
  For I = I0 + 1 To UBound(aData)
    If aData(I) < aData(P) Then P = I
  Next I
  If P <> I0 Then
    V = aData(I0)
    aData(I0) = aData(P)
    aData(P) = V
  End If
Next I0
End Sub

Private Sub DataInit(aData() As DataType, Range As Range)
Dim N As Long, R As Long
N = Range.Rows.Count
ReDim aData(0 To N)
For R = 1 To N
  With aData(R)
    .Sachnummer = Range(R, 1)
    .Lieferant = Range(R, 2)
    .Bezeichnung = Range(R, 3)
    .Verkaufspreis = Range(R, 4)
    .Gewicht = Range(R, 5)
    .Zolltarifnummer = Range(R, 6)
  End With
Next R
End Sub

Private Sub DataPrecise(aData() As DataType, Range As Range)
Dim R As Long, N As Long, I As Long, D As DataType
N = Range.Rows.Count
For R = 1 To N
  With D
    .Sachnummer = Range(R, 1)
    .Lieferant = Range(R, 2)
    .Bezeichnung = Range(R, 3)
    .Verkaufspreis = Range(R, 4)
    .Gewicht = Range(R, 5)
    .Zolltarifnummer = Range(R, 6)
  End With
  I = ArrayItemFind(aData(), D.Sachnummer)
  If I = 0 Then
    '*** START POINT 2 ***
    'ArrayItemInsert aData(), D
    '*** END POINT 2 ***
  Else
    If aData(I).Lieferant = D.Lieferant Then
      aData(I) = D
    Else
      aData(I) = D
    End If
  End If
Next R
'*** START POINT 3 ***
N = UBound(aData)
For I = N To 1 Step -1
  If Range.Find(What:=aData(I).Sachnummer, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) Is Nothing Then
    ArrayItemRemove aData(), I
  End If
Next I
'*** END POINT 3 ***
End Sub

Private Function ArrayItemFind(aData() As DataType, ByVal Code As String) As Long
Dim I As Long
For I = UBound(aData) To 1 Step -1
  If aData(I).Sachnummer = Code Then Exit For
Next I
ArrayItemFind = I
End Function

Private Sub ArrayItemInsert(aData() As DataType, Data As DataType, Optional ByVal ItemIndex As Long = 0)
Dim I As Long
If ItemIndex = 0 Then ItemIndex = UBound(aData) + 1
ReDim Preserve aData(0 To UBound(aData) + 1)
For I = UBound(aData) To ItemIndex + 1 Step -1
  aData(I) = aData(I - 1)
Next I
aData(ItemIndex) = Data
End Sub

Private Sub ArrayItemRemove(aData() As DataType, ByVal ItemIndex As Long)
Dim I As Long
For I = ItemIndex + 1 To UBound(aData)
  aData(I - 1) = aData(I)
Next I
ReDim Preserve aData(0 To UBound(aData) - 1)
End Sub

Sub GetResult()
Dim P As String, F As String, X() As String, D() As DataType, W As Long
Dim wb As Workbook, sh As Worksheet, R0 As Long, R As Long
ReDim X(0)
'*** START POINT 1 ***
P = "C:\"
'*** END POINT 1 ***
F = Dir$(P & "lieferant_*.xls")
Do While Len(F) > 0
  ReDim Preserve X(0 To UBound(X) + 1)
  X(UBound(X)) = P & F
  F = Dir$()
Loop
If UBound(X) = 0 Then
  MsgBox "Files not found."
  End
End If
If UBound(X) = 1 Then
  MsgBox "Only one file."
  End
End If
SortArrayString X()
ReDim D(0)
For W = 1 To UBound(X)
  Set wb = Workbooks.Open(X(W))
  Set sh = wb.Worksheets(1)
  R0 = 1
  R = R0
  Do
    R = R + 1
    If Len(sh.Cells(R, 1).Text) = 0 Then Exit Do
  Loop
  If W = 1 Then
    DataInit D(), sh.Range("A" & R0 + 1 & ":F" & R - 1)
  Else
    DataPrecise D(), sh.Range("A" & R0 + 1 & ":F" & R - 1)
  End If
  Set sh = Nothing
  wb.Close False
  Set wb = Nothing
Next W
ThisWorkbook.ActiveSheet.Cells.ClearContents
R0 = 1
For R = R0 + 1 To R0 + UBound(D)
  ThisWorkbook.ActiveSheet.Cells(R, 1) = D(R - R0).Sachnummer
  ThisWorkbook.ActiveSheet.Cells(R, 2) = D(R - R0).Lieferant
  ThisWorkbook.ActiveSheet.Cells(R, 3) = D(R - R0).Bezeichnung
  ThisWorkbook.ActiveSheet.Cells(R, 4) = D(R - R0).Verkaufspreis
  ThisWorkbook.ActiveSheet.Cells(R, 5) = D(R - R0).Gewicht
  ThisWorkbook.ActiveSheet.Cells(R, 6) = D(R - R0).Zolltarifnummer
Next R
MsgBox "Done."
End Sub


[elena]

спасибо вам alibek , буду читать книжку и разбираться с Вашим макросом. я не предпологала что макрос может быть такой огромный.