2. Forms

   1. FrmЗапросы

Option Base 1

Private Sub UserForm_Initialize()

Dim Месяц(2) As String

Месяц(1) = "Апрель"

Месяц(2) = "Март"

frmЗапросы.cboМесяц.List = Месяц

End Sub

Private Sub cboМесяц_Change()

ВыбранныйМесяц = frmЗапросы.cboМесяц.Value

Call СуществованиеФайла(ВыбранныйМесяц)

Call ЗаполнениеСтраны(ВыбранныйМесяц)

End Sub

Sub ЗаполнениеСтраны(ВыбранныйМесяц)

Dim Страны() As String

Dim Страна As String

Dim НомерСтроки As Integer

Dim КолСтран, k, i, j As Integer

Workbooks(ВыбранныйМесяц).Activate

ReDim Preserve Страны(1) As String

КолСтран = 0

For z = 1 To Worksheets.Count

Sheets(z).Activate

НомерСтроки = 2

While Trim(Cells(НомерСтроки, 1).Value) <> ""

Страна = Trim(Cells(НомерСтроки, 3).Value)

For j = 1 To КолСтран

If Страна = Страны(j) Then GoTo a1

Next j

КолСтран = КолСтран + 1

ReDim Preserve Страны(КолСтран) As String

Страны(КолСтран) = Trim(Cells(НомерСтроки, 3).Value)

a1: НомерСтроки = НомерСтроки + 1

Wend

Next z

For i = 1 To КолСтран - 1

Страна = Страны(i)

k = i

For j = i + 1 To КолСтран

If Страны(j) >= Страна Then

Else

Страна = Страны(j)

Страны(j) = Страны(k)

Страны(k) = Страна

End If

Next

Next i

Worksheets(1).Select

Range("A1").Select

frmЗапросы.lstСтраны.List = Страны

frmЗапросы.lstСтраны.MultiSelect = fmMultiSelectMulti

frmЗапросы.lstСтраны.Selected(0) = True

End Sub

Sub cmdОК_Click()

Dim ВыбранныйМесяц As String

Dim ВыбранныеСтраны() As String

Dim КолСтран, НачалоСтраны As Integer

ВыбранныйМесяц = frmЗапросы.cboМесяц.Value

For i = 0 To lstСтраны.ListCount - 1

If lstСтраны.Selected(i) = True Then

КолСтран = КолСтран + 1

For t = 1 To КолСтран

ReDim Preserve ВыбранныеСтраны(КолСтран) _

As String

ВыбранныеСтраны(КолСтран) = _

frmЗапросы.lstСтраны.List(i)

Next t

End If

Next i

If КолСтран = 0 Then

Unload frmЗапросы

MsgBox "Ни одна страна не выбрана!", vbInformation

End

End If

Unload frmЗапросы

Call СохранениеФайла(ВыбранныйМесяц, КолСтран)

НомерСтроки = 2

НачалоСтраны = 3

For i = 1 To КолСтран

Страна = ВыбранныеСтраны(i)

Workbooks("Страны.xls").Activate

While Trim(Cells(НачалоСтраны, 1).Value) <> ""

НачалоСтраны = НачалоСтраны + 1

Wend

Call ЗаполнениеТаблицы(Страна, ВыбранныйМесяц, НачалоСтраны)

НачалоСтраны = НачалоСтраны + 1

Next i

Call ОформлениеПослСтр

Range("A1").Select

ActiveWorkbook.Save

MsgBox "Операция завершена!", vbInformation

End Sub

Sub cmdОтмена_Click()

Unload Me

End Sub

2. FrmОПрограмме

Private Sub cmdOK_Click()

Unload Me

End Sub

3. Modules

   1. Module1

Sub ФормаЗапросы()

frmЗапросы.Show

End Sub

Sub ФормаОПрограмме()

frmОПрограмме.Show

End Sub

2. Сохранение

Option Base 1

Dim НачалоОформления As Integer

Dim КолЗапрВыбрСтраны As Integer

Sub СохранениеФайла(ВыбранныйМесяц, КолСтран)

Dim Path, Папка, Путь As String

Dim i As Integer

Path = "F:\Запросы\" & ВыбранныйМесяц

Папка = Dir(Path, vbDirectory)

If Папка = "" Then

MkDir (Path)

End If

For i = 1 To Workbooks.Count

If Workbooks(i).Name = "Страны.xls" Then

Workbooks(i).Close SaveChanges:=False

Exit For

End If

Next

Путь = "F:\Запросы\" & ВыбранныйМесяц & "\Страны.xls"

If Dir(Путь) = "" Then

Листов = Application.SheetsInNewWorkbook

Application.SheetsInNewWorkbook = 1

Workbooks.Add

ActiveSheet.Name = Date

ActiveWorkbook.SaveAs Filename:=Путь

Else

Кнопка = MsgBox("Файл " & Filename & " уже существует. _

Заменить его?", vbYesNo + vbQuestion + vbDefaulfButton1)

Select Case Кнопка

Case vbYes

For i = 1 To Workbooks.Count

If Workbooks(i).Name = "Страны.xls" Then

Workbooks("Страны.xls").Close _

SaveChanges:=False

Exit For

End If

Next i

Kill Путь

Листов = Application.SheetsInNewWorkbook

Application.SheetsInNewWorkbook = 1

Workbooks.Add

ActiveSheet.Name = Date

ActiveWorkbook.SaveAs Filename:=Путь

Case vbNo

End

End Select

End If

Application.SheetsInNewWorkbook = Листов

End Sub

Sub ЗаполнениеТаблицы(Страна, ВыбранныйМесяц, НачалоСтраны)

Dim Запросы() As String

Dim КолЗапрВыбрСтраны As String

Dim z, i, k, НомерСтроки, Сумма, Сумма2 As Integer

Call СозданиеШапки

КолЗапрВыбрСтраны = 0

Сумма = 0

Сумма2 = 0

Call СуществованиеФайла(ВыбранныйМесяц)

For z = 1 To Worksheets.Count

Workbooks(ВыбранныйМесяц).Worksheets(z).Activate

НомерСтроки = 2

ЧислоОфСтр = 0

While Trim(Cells(НомерСтроки, 1).Value) <> ""

If Trim(Cells(НомерСтроки, 3).Value) = Страна Then

КолЗапрВыбрСтраны = КолЗапрВыбрСтраны + 1

ЧислоОфСтр = ЧислоОфСтр + 1

ReDim Preserve Запросы(7, КолЗапрВыбрСтраны)

Запросы(1, КолЗапрВыбрСтраны) = _

Worksheets(z).Name

Запросы(2, КолЗапрВыбрСтраны) = _

Cells(НомерСтроки, 1).Value

Запросы(3, КолЗапрВыбрСтраны) = _

Cells(НомерСтроки, 2).Value

Запросы(4, КолЗапрВыбрСтраны) = _

Cells(НомерСтроки, 3).Value

Запросы(5, КолЗапрВыбрСтраны) = _

Cells(НомерСтроки, 4).Value

Запросы(6, КолЗапрВыбрСтраны) = _

Cells(НомерСтроки, 5).Value

Запросы(7, КолЗапрВыбрСтраны) = _

Cells(НомерСтроки, 6).Value

End If

НомерСтроки = НомерСтроки + 1

Wend

Workbooks("Страны.xls").Activate

For i = 1 To КолЗапрВыбрСтраны

Cells(i + НачалоСтраны - 1, 1).Value = Запросы(1, i)

Cells(i + НачалоСтраны - 1, 2).Value = Запросы(2, i)

Cells(i + НачалоСтраны - 1, 3).Value = Запросы(3, i)

Cells(i + НачалоСтраны - 1, 4).Value = Запросы(4, i)

Cells(i + НачалоСтраны - 1, 5).Value = Запросы(5, i)

Cells(i + НачалоСтраны - 1, 6).Value = Запросы(6, i)

Cells(i + НачалоСтраны - 1, 7).Value = Запросы(7, i)

Next i

If ЧислоОфСтр <> 0 Then

Call ОформлениеСформированнойТаблицы(ЧислоОфСтр, _

Страна)

End If

Next

Range(Cells(НачалоСтраны, 1), Cells(НачалоСтраны + КолЗапрВыбрСтраны - 1, 7)).Select

Selection.Sort Key1:=Cells(НачалоСтраны, 1), Order1:= _

xlAscending, Header:=xlGuess, Key2:=Cells(НачалоСтраны, 5), _

Order1:=xlAscending, Header:=xlGuess

For k = 1 To КолЗапрВыбрСтраны

Сумма = Сумма + Cells(k + НачалоСтраны - 1, 6).Value

Сумма2 = Сумма2 + Cells(k + НачалоСтраны - 1, 7).Value

Next

Call ОформлениеИтого(Страна, Сумма, Сумма2)

End Sub

Sub ОформлениеСформированнойТаблицы(ЧислоОфСтр, Страна)

НачалоОформления = 2

While Trim(Cells(НачалоОформления, 1)) <> ""

НачалоОформления = НачалоОформления + 1

Wend

Range(Cells(НачалоОформления - ЧислоОфСтр, 1), _

Cells(НачалоОформления - 1, 7)).Select

With Selection.Font

.Name = "Calibri"

.Size = 10

End With

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.WrapText = True

End With

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlDouble

.ColorIndex = 1

End With

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.ColorIndex = 1

End With

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ColorIndex = 1

End With

With Selection.Borders(xlEdgeRight)

.LineStyle = xlDouble

.ColorIndex = 1

End With

If ЧислоОфСтр > 1 Then

With Selection.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.ColorIndex = 1

End With

End If

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.ColorIndex = 1

End With

Range(Cells(НачалоОформления - ЧислоОфСтр, 3), _

Cells(НачалоОформления - 1, 3)).Select

Selection.NumberFormat = "m/d/yyyy"

End Sub

Sub СозданиеШапки()

Range("A1:G1").Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.MergeCells = True

End With

ActiveCell.FormulaR1C1 = "Информация о запросах из стран"

Selection.Font.Bold = True

With Selection.Font

.Name = "Calibri"

.Size = 12

End With

Range("A2") = "Сайт"

Range("B2") = "Текст запроса"

Range("C2") = "Дата запроса"

Range("D2") = "Страна"

Range("E2") = "Поисковая система"

Range("F2") = "Время на сайте, мин"

Range("G2") = "Количество посещённых страниц"

Range("A2:G2").Select

With Selection.Font

.Name = "Calibri"

.Size = 12

End With

Selection.Font.Bold = True

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.WrapText = True

End With

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlDouble

.ColorIndex = 1

End With

With Selection.Borders(xlEdgeTop)

.LineStyle = xlDouble

.ColorIndex = 1

End With

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ColorIndex = 1

End With

With Selection.Borders(xlEdgeRight)

.LineStyle = xlDouble

.ColorIndex = 1

End With

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.ColorIndex = 1

End With

Columns("C:C").ColumnWidth = 10

Columns("D:D").ColumnWidth = 11

Columns("E:E").ColumnWidth = 11

Columns("F:F").ColumnWidth = 9

Columns("G:G").ColumnWidth = 13

End Sub

Sub ОформлениеИтого(Страна, Сумма, Сумма2)

НачалоИтого = 2

While Trim(Cells(НачалоИтого, 1)) <> ""

НачалоИтого = НачалоИтого + 1

Wend

Range(Cells(НачалоИтого, 1), Cells(НачалоИтого, 5)).Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.MergeCells = True

End With

ActiveCell.FormulaR1C1 = "Итого по " & Страна & ":"

Range(Cells(НачалоИтого, 1), Cells(НачалоИтого, 7)).Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

Selection.Font.Bold = True

With Selection.Font

.Name = "Calibri"

.Size = 12

End With

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlDouble

.ColorIndex = 1

End With

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.ColorIndex = 1

End With

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ColorIndex = 1

End With

With Selection.Borders(xlEdgeRight)

.LineStyle = xlDouble

.ColorIndex = 1

End With

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.ColorIndex = 1

End With

Cells(НачалоИтого, 6).Value = Сумма

Cells(НачалоИтого, 7).Value = Сумма2

End Sub

Sub ОформлениеПослСтр()

ПослСтр = 2

While Trim(Cells(ПослСтр, 1)) <> ""

ПослСтр = ПослСтр + 1

Wend

Range(Cells(ПослСтр - 1, 1), Cells(ПослСтр - 1, 7)).Select

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlDouble

.ColorIndex = 1

End With

End Sub