Автор: vlth
Дата сообщения: 17.03.2010 01:20
Valentino10, вот Ваш модуль. Замените название "Лист2" на имя листа, с которого берёте данные. Из 2х процедур - prcCopyRange() и prcCopyRange2() - выберите ту, которая Вас больше устроит (prcCopyRange() добавляет данные на новый лист, prcCopyRange2() - заменяет данные "нового" листа)
Код: Option Explicit
Sub prcCopyRange()
Dim x As String, oRangeToCopy As Range, lngLastRow As Long
x = InputBox("Введите название населённого пункта", "Город, село, деревня...", "москва")
If Len(x) > 0 Then
x = fncMakeName(x)
Set oRangeToCopy = fncReturnRange(x)
If Not oRangeToCopy Is Nothing Then
With ThisWorkbook.Worksheets
If Not fncIsExistsWS(x) Then
.Add After:=.Item(.Count)
.Item(.Count).Name = x
Set oRangeToCopy = _
Union(Range(.Item("Лист2").Cells(1, 1), _
.Item("Лист2").Cells(1, 11)), oRangeToCopy)
End If
lngLastRow = .Item(x).Cells(.Item(x).Rows.Count, 1).End(xlUp)
oRangeToCopy.Copy .Item(x).Cells(lngLastRow + 1, 1)
End With
End If
End If
End Sub
Sub prcCopyRange2()
Dim x As String, oRangeToCopy As Range
x = InputBox("Введите название населённого пункта", "Город, село, деревня...", "москва")
If Len(x) > 0 Then
x = fncMakeName(x)
Set oRangeToCopy = fncReturnRange(x)
If Not oRangeToCopy Is Nothing Then
With ThisWorkbook.Worksheets
If Not fncIsExistsWS(x) Then
.Add After:=.Item(.Count)
.Item(.Count).Name = x
End If
Set oRangeToCopy = _
Union(Range(.Item("Лист2").Cells(1, 1), _
.Item("Лист2").Cells(1, 11)), oRangeToCopy)
.Item(x).Cells(1, 1).CurrentRegion.Clear
oRangeToCopy.Copy .Item(x).Cells(1, 1)
End With
End If
End If
End Sub
Function fncMakeName(strNameOfPoint As String) As String
Dim astrArray() As String, i As Byte, x As String
astrArray = Split(strNameOfPoint)
For i = 0 To UBound(astrArray)
x = Trim(astrArray(i))
astrArray(i) = UCase(Left(x, 1)) & LCase(Right(x, Len(x) - 1))
Next i
fncMakeName = Join(astrArray)
End Function
Function fncReturnRange(strSearch As String) As Range
Dim oCell As Range, oRange As Range, strFAddr As String
With ThisWorkbook.Worksheets("Лист2")
Set oCell = .Columns(1).Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole)
If Not oCell Is Nothing Then
strFAddr = oCell.Address
Set oRange = Range(oCell, oCell.Offset(, 10))
Do
Set oCell = .Columns(1).FindNext(oCell)
If oCell.Address <> strFAddr Then
Set oRange = Union(oRange, Range(oCell, oCell.Offset(, 10)))
Else: Exit Do
End If
Loop Until oCell Is Nothing
End If
End With
Set fncReturnRange = oRange
End Function
Function fncIsExistsWS(strWSName As String) As Boolean
Dim WS As Worksheet
For Each WS In ThisWorkbook.Worksheets
If WS.Name = strWSName Then
fncIsExistsWS = True
Exit Function
End If
Next
End Function
