Макрос переноса данных

[TbIL]

Доброго времени суток! Буду рад вашей помощи, так как в программирование не силен. Нужен макрос - перенос цифровых значений определенного цвета из ворда в эксель, каждое число в отдельную ячейку. Для каждого файла ворд своя строка в эксель.

[Казанский]

Нужен пример: несколько файлов Word и что должно получаться в Excel.

[СтаниславАВ]

Попробуй такой макрос

PHP код:

Sub Îáíîâèòü()
Dim i As Integer
Dim ÊîëÑòðîê As Integer
Application.ScreenUpdating = False
Sheets("Áóìàãè").Select
ÊîëÑòðîê = Application.WorksheetFunction.CountA(Range("F:F"))
Range("A2:Q" + CStr(ÊîëÑòðîê)).Select
Selection.ClearContents
With Selection.Interior
    .Pattern = xlNone
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Sheets("Îöåíêà").Select
ÊîëÑòðîê = Application.WorksheetFunction.CountA(Range("F:F"))
t = 1
For i = 2 To ÊîëÑòðîê
If IsNumeric(Cells(i, 17).Value) Then
  If Cells(i, 17).Value > Cells(1, 18).Value Then
       t = t + 1
       Sheets("Îöåíêà").Select
              Range("A" + CStr(i) + ":Q" + CStr(i)).Select
       Selection.Copy
       Sheets("Áóìàãè").Select
       Range("A" + CStr(t)).Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       Sheets("Îöåíêà").Select
  End If
End If
Next i
 
Sheets("Áóìàãè").Select
Range("A" + CStr(t)).Select
Application.ScreenUpdating = True
End Sub 


[СтаниславАВ]

Попробуй такой макрос

PHP код:

Sub Îáíîâèòü()
Dim i As Integer
Dim ÊîëÑòðîê As Integer
Application.ScreenUpdating = False
Sheets("Áóìàãè").Select
ÊîëÑòðîê = Application.WorksheetFunction.CountA(Range("F:F"))
Range("A2:Q" + CStr(ÊîëÑòðîê)).Select
Selection.ClearContents
With Selection.Interior
    .Pattern = xlNone
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Sheets("Îöåíêà").Select
ÊîëÑòðîê = Application.WorksheetFunction.CountA(Range("F:F"))
t = 1
For i = 2 To ÊîëÑòðîê
If IsNumeric(Cells(i, 17).Value) Then
  If Cells(i, 17).Value > Cells(1, 18).Value Then
       t = t + 1
       Sheets("Îöåíêà").Select
              Range("A" + CStr(i) + ":Q" + CStr(i)).Select
       Selection.Copy
       Sheets("Áóìàãè").Select
       Range("A" + CStr(t)).Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       Sheets("Îöåíêà").Select
  End If
End If
Next i
 
Sheets("Áóìàãè").Select
Range("A" + CStr(t)).Select
Application.ScreenUpdating = True
End Sub