Доброго дня уважаемые форумчане. Столкнулся с трудностями написания задачки, прошу вашей помощи как специалистов. Пытаюсь составить тест по географии мира.
Есть файл excel 2007, в нем 4 листа, на главной (лист1) сам тест, а на остальных исходные данные для него. Нужно что бы на главной странице при нажатии кнопки далее отображалось следующее задание и появлялись другие соответствующие кнопки. Такое вообще возможно, что бы не клепать 194 страницы в документе? Исходник прикрепляю во вложении, заранее благодарю.
Доброго дня уважаемые форумчане. Столкнулся с трудностями написания задачки, прошу вашей помощи как специалистов. Пытаюсь составить тест по географии мира.
Есть файл excel 2007, в нем 4 листа, на главной (лист1) сам тест, а на остальных исходные данные для него. Нужно что бы на главной странице при нажатии кнопки далее отображалось следующее задание и появлялись другие соответствующие кнопки. Такое вообще возможно, что бы не клепать 194 страницы в документе? Исходник прикрепляю во вложении, заранее благодарю.Markus
Цель, нажимая кнопки ответа страны должны появляться новые кнопки с флагом взятых из других листов. Я не силен в дебрях, потому прошу помощи, ребята...
Цель, нажимая кнопки ответа страны должны появляться новые кнопки с флагом взятых из других листов. Я не силен в дебрях, потому прошу помощи, ребята...Markus
Непонятно зачем на каждую страну свою кнопку, достаточно выводить название страны на кнопку. Структуру базы надо переделывать, типа в первом столбце название страны, во втором столица и т.д. Флаги тоже в этой таблице должны быть. В общем надо задачу разбивать на маленькие подзадачи и для каждой тему создавать, или в раздел фриланс идти
Непонятно зачем на каждую страну свою кнопку, достаточно выводить название страны на кнопку. Структуру базы надо переделывать, типа в первом столбце название страны, во втором столица и т.д. Флаги тоже в этой таблице должны быть. В общем надо задачу разбивать на маленькие подзадачи и для каждой тему создавать, или в раздел фриланс идти Udik
вот вам барабан яд 41001231307558 wm R419131876897 udik1968@gmail.com
Действительно, можно выводить надписи на кнопках. Конечно, структуру базы можно и переделать, но я уже в этом не силен, буду благодарени за любую помощь...
Действительно, можно выводить надписи на кнопках. Конечно, структуру базы можно и переделать, но я уже в этом не силен, буду благодарени за любую помощь...Markus
Option Explicit Public Const NumCountry As Integer = 190 Public arrCountry(1 To NumCountry) As String
Sub ДАЛЕЕ() ''надо дописать код End Sub
Public Sub buttCountry(nameCountry As String, numButt As Integer) Dim i As Integer Dim str1 As String
If arrCountry(1) = "" Then Call setArr With Worksheets("basa") For i = 1 To NumCountry If arrCountry(i) = nameCountry Then Exit For Next i ActiveSheet.Cells(7, 4) = .Cells(i, 2) ActiveSheet.Cells(8, 4) = .Cells(i, 4) ActiveSheet.Cells(9, 4) = .Cells(i, 3) Call DeleteShapesInRange str1 = .Cells(i, 5) pastePic (str1) End With End Sub
Sub pastePic(str1 As String) ' Sheets("basa").Select ActiveSheet.Shapes.Range(Array(str1)).Select Selection.Copy Sheets("Лист1").Select Range("C4").Select ActiveSheet.Paste End Sub
Public Sub setArr() Dim i As Integer
For i = 1 To NumCountry arrCountry(i) = Worksheets("basa").Cells(i, 1) Next i End Sub ' ' эти две функции честно стырены на просторах инета Sub DeleteShapesInRange() Dim ra As Range: Set ra = ActiveSheet.Cells(4, 3) ' задаём диапазон для поиска картинок On Error Resume Next ' на случай, если картинок в заданном диапазоне нет ShapesInRange(ra).Delete ' удаляем все картинки в диапазоне ra End Sub Function ShapesInRange(ByRef ra As Range) As ShapeRange On Error Resume Next: Dim a(), i&, n&, Shps As Shapes Set Shps = ra.Worksheet.Shapes If Shps.Count = 0 Then Exit Function ReDim a(1 To Shps.Count)
For i = 1 To Shps.Count With Shps.Item(i) If .Type = msoPicture Or .Type = msoLinkedPicture Then If Not Intersect(ra.Worksheet.Range(.TopLeftCell, .BottomRightCell), ra) Is Nothing Then n = n + 1: a(n) = i End If End If End With Next If n Then ReDim Preserve a(1 To n): Set ShapesInRange = Shps.Range(a) End Function
[/vba]
При вставке очередной картинки моргает, т.к. тупо с макрорекодера передрал код. Как shape копировать/вставлять по другому не знаю
Ну вот основа для дальнейшего
[vba]
Код
Option Explicit Public Const NumCountry As Integer = 190 Public arrCountry(1 To NumCountry) As String
Sub ДАЛЕЕ() ''надо дописать код End Sub
Public Sub buttCountry(nameCountry As String, numButt As Integer) Dim i As Integer Dim str1 As String
If arrCountry(1) = "" Then Call setArr With Worksheets("basa") For i = 1 To NumCountry If arrCountry(i) = nameCountry Then Exit For Next i ActiveSheet.Cells(7, 4) = .Cells(i, 2) ActiveSheet.Cells(8, 4) = .Cells(i, 4) ActiveSheet.Cells(9, 4) = .Cells(i, 3) Call DeleteShapesInRange str1 = .Cells(i, 5) pastePic (str1) End With End Sub
Sub pastePic(str1 As String) ' Sheets("basa").Select ActiveSheet.Shapes.Range(Array(str1)).Select Selection.Copy Sheets("Лист1").Select Range("C4").Select ActiveSheet.Paste End Sub
Public Sub setArr() Dim i As Integer
For i = 1 To NumCountry arrCountry(i) = Worksheets("basa").Cells(i, 1) Next i End Sub ' ' эти две функции честно стырены на просторах инета Sub DeleteShapesInRange() Dim ra As Range: Set ra = ActiveSheet.Cells(4, 3) ' задаём диапазон для поиска картинок On Error Resume Next ' на случай, если картинок в заданном диапазоне нет ShapesInRange(ra).Delete ' удаляем все картинки в диапазоне ra End Sub Function ShapesInRange(ByRef ra As Range) As ShapeRange On Error Resume Next: Dim a(), i&, n&, Shps As Shapes Set Shps = ra.Worksheet.Shapes If Shps.Count = 0 Then Exit Function ReDim a(1 To Shps.Count)
For i = 1 To Shps.Count With Shps.Item(i) If .Type = msoPicture Or .Type = msoLinkedPicture Then If Not Intersect(ra.Worksheet.Range(.TopLeftCell, .BottomRightCell), ra) Is Nothing Then n = n + 1: a(n) = i End If End If End With Next If n Then ReDim Preserve a(1 To n): Set ShapesInRange = Shps.Range(a) End Function
[/vba]
При вставке очередной картинки моргает, т.к. тупо с макрорекодера передрал код. Как shape копировать/вставлять по другому не знаюUdik
подправил вставку, теперь не моргает и лист базы можно скрыть
[vba]
Код
Option Explicit Public Const NUMCOUNTRY As Integer = 190 Public arrCountry(1 To NUMCOUNTRY) As String Public arrNameShape(1 To NUMCOUNTRY) As String
Sub nextGen() ''надо дописать код If arrCountry(1) = "" Then Call setArr Call setButtCaption(4, 5, 6)
End Sub
Public Sub buttCountry(nameCountry As String, numButt As Integer) Dim i As Integer Dim str1 As String
If arrCountry(1) = "" Then Call setArr With Worksheets("basa") For i = 1 To NUMCOUNTRY If arrCountry(i) = nameCountry Then Exit For Next i ActiveSheet.Cells(7, 4) = .Cells(i, 2) ActiveSheet.Cells(8, 4) = .Cells(i, 4) ActiveSheet.Cells(9, 4) = .Cells(i, 3)
Call DeleteShapesInRange Call pastePic(arrNameShape(i)) End With End Sub
Sub pastePic(str1 As String) Dim shp As Shape
Set shp = Worksheets("basa").Shapes(str1)
shp.Copy ActiveSheet.Paste (ActiveSheet.Cells(4, 3)) ActiveSheet.Cells(4, 4).Select End Sub
Public Sub setArr() Dim i As Integer
With Worksheets("basa") For i = 1 To NUMCOUNTRY arrCountry(i) = .Cells(i, 1) arrNameShape(i) = .Cells(i, 5) If i + 1 > .Shapes.Count Then Exit For Next i End With End Sub ' ' эти две функции честно стырены на просторах инета Sub DeleteShapesInRange() Dim ra As Range: Set ra = ActiveSheet.Cells(4, 3) ' задаём диапазон для поиска картинок On Error Resume Next ' на случай, если картинок в заданном диапазоне нет ShapesInRange(ra).Delete ' удаляем все картинки в диапазоне ra End Sub Function ShapesInRange(ByRef ra As Range) As ShapeRange On Error Resume Next: Dim a(), i&, n&, Shps As Shapes Set Shps = ra.Worksheet.Shapes If Shps.Count = 0 Then Exit Function ReDim a(1 To Shps.Count)
For i = 1 To Shps.Count With Shps.Item(i) If .Type = msoPicture Or .Type = msoLinkedPicture Then If Not Intersect(ra.Worksheet.Range(.TopLeftCell, .BottomRightCell), ra) Is Nothing Then n = n + 1: a(n) = i End If End If End With Next If n Then ReDim Preserve a(1 To n): Set ShapesInRange = Shps.Range(a) End Function
Public Sub setButtCaption(i As Integer, j As Integer, k As Integer)
With Worksheets("Лист1") .CommandButton1.Caption = arrCountry(i) .CommandButton2.Caption = arrCountry(j) .CommandButton3.Caption = arrCountry(k) End With End Sub
[/vba]
подправил вставку, теперь не моргает и лист базы можно скрыть
[vba]
Код
Option Explicit Public Const NUMCOUNTRY As Integer = 190 Public arrCountry(1 To NUMCOUNTRY) As String Public arrNameShape(1 To NUMCOUNTRY) As String
Sub nextGen() ''надо дописать код If arrCountry(1) = "" Then Call setArr Call setButtCaption(4, 5, 6)
End Sub
Public Sub buttCountry(nameCountry As String, numButt As Integer) Dim i As Integer Dim str1 As String
If arrCountry(1) = "" Then Call setArr With Worksheets("basa") For i = 1 To NUMCOUNTRY If arrCountry(i) = nameCountry Then Exit For Next i ActiveSheet.Cells(7, 4) = .Cells(i, 2) ActiveSheet.Cells(8, 4) = .Cells(i, 4) ActiveSheet.Cells(9, 4) = .Cells(i, 3)
Call DeleteShapesInRange Call pastePic(arrNameShape(i)) End With End Sub
Sub pastePic(str1 As String) Dim shp As Shape
Set shp = Worksheets("basa").Shapes(str1)
shp.Copy ActiveSheet.Paste (ActiveSheet.Cells(4, 3)) ActiveSheet.Cells(4, 4).Select End Sub
Public Sub setArr() Dim i As Integer
With Worksheets("basa") For i = 1 To NUMCOUNTRY arrCountry(i) = .Cells(i, 1) arrNameShape(i) = .Cells(i, 5) If i + 1 > .Shapes.Count Then Exit For Next i End With End Sub ' ' эти две функции честно стырены на просторах инета Sub DeleteShapesInRange() Dim ra As Range: Set ra = ActiveSheet.Cells(4, 3) ' задаём диапазон для поиска картинок On Error Resume Next ' на случай, если картинок в заданном диапазоне нет ShapesInRange(ra).Delete ' удаляем все картинки в диапазоне ra End Sub Function ShapesInRange(ByRef ra As Range) As ShapeRange On Error Resume Next: Dim a(), i&, n&, Shps As Shapes Set Shps = ra.Worksheet.Shapes If Shps.Count = 0 Then Exit Function ReDim a(1 To Shps.Count)
For i = 1 To Shps.Count With Shps.Item(i) If .Type = msoPicture Or .Type = msoLinkedPicture Then If Not Intersect(ra.Worksheet.Range(.TopLeftCell, .BottomRightCell), ra) Is Nothing Then n = n + 1: a(n) = i End If End If End With Next If n Then ReDim Preserve a(1 To n): Set ShapesInRange = Shps.Range(a) End Function
Public Sub setButtCaption(i As Integer, j As Integer, k As Integer)
With Worksheets("Лист1") .CommandButton1.Caption = arrCountry(i) .CommandButton2.Caption = arrCountry(j) .CommandButton3.Caption = arrCountry(k) End With End Sub