Трабла с переносом данных...

[winfacks]

Неужто господа суперспециалисты не смогут решить данный трабл?
Чесно говоря руки опускаються ...
Может есть идеи как по другому сделать перенос данных с листов на сводных лист?
Вдруг это "фича" 2007 ехеля, и не лечиться, а только обходиться?

[winfacks]

А можно ли переписать функцию переноса данных с варианта перебора листов:
Private Sub KB2_Click()

Application.ScreenUpdating = False: On Error Resume Next
KB1_Click
Dim sh As Worksheet, r As Range, ra As Range

For Each sh In ThisWorkbook.Worksheets
If sh.Name Like Not "*Свод*" Then
For Each cell In sh.Range("f:f").SpecialCells(xlCell TypeConstants)
If cell <= Cells.Range("a1") Then
Set ra = Application.Intersect(cell.EntireRo w, sh.Range("a:ah"))
Me.Range("a65000").End(xlUp).Offset (1).Resize(, ra.Cells.Count).Value = ra.Value
End If
Next cell
End If
Next sh
Me.[a1].Select
Application.CutCopyMode = False

End Sub
На вариант Union как в sql? тоесть задать ему несколько диапазонов, потом их обьединить и положить на указаный лист - может так нормально заработает?
Вот только как етот юнион туды прилепить ... прочитал справку - там написаны только 2 массива - остальное какие то переменные ... или я не туда посмотрел...
Подкинте плз вариант для размышлений!

[winfacks]

может быть что то типа такого? тока кде то тама сАпАка парылася (блин ) ПамаГите!!!!!
Private Sub CommandButton2_Click()

Dim r1 As Range, r2 As Range, r3 As Range, r5 As Range, r6 As Range, ra As Range, ru As Range

For Each cell In Worksheets("Демшевский").Range("f:f ").SpecialCells(xlCellTypeConstants )
If cell <= Cells.Range("a1") Then
Set ra = Intersect(cell.EntireRow, Worksheets("Демшевский").Range("a:a h"))
r1.Value = ra.Value
End If
Next cell

For Each cell In Worksheets("Чернеженко").Range("f:f ").SpecialCells(xlCellTypeConstants )
If cell <= Cells.Range("a1") Then
Set ra = Intersect(cell.EntireRow, Worksheets("Чернеженко").Range("a:a h"))
r2.Value = ra.Value
End If
Next cell

For Each cell In Worksheets("Чеботарева").Range("f:f ").SpecialCells(xlCellTypeConstants )
If cell <= Cells.Range("a1") Then
Set ra = Intersect(cell.EntireRow, Worksheets("Чеботарева").Range("a:a h"))
r3.Value = ra.Value
End If
Next cell

For Each cell In Worksheets("Переверзева").Range("f: f").SpecialCells(xlCellTypeConstant s)
If cell <= Cells.Range("a1") Then
Set ra = Intersect(cell.EntireRow, Worksheets("Переверзева").Range("a: ah"))
r5.Value = ra.Value
End If
Next cell

For Each cell In Worksheets("Коморна").Range("f:f"). SpecialCells(xlCellTypeConstants)
If cell <= Cells.Range("a1") Then
Set ra = Intersect(cell.EntireRow, Worksheets("Коморна").Range("a:ah") )
r6.Value = ra.Value
End If
Next cell

ru = Union(r1.Value, r2.Value, r3.Value, r5.Value, r6.Value)
Me.Range("a65000").End(xlUp).Offset (1).Resize(, ru.Cells.Count).Value = ru.Value
Me.[a1].Select
Application.CutCopyMode = False
End Sub