Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
Przesunięty przez: umiejead
24-01-2019, 04:39
Pomoc w projekcie WDI środek ciężkości
Autor Wiadomość
Polok12344
świeżak


Posty: 3
Wysłany: 24-01-2019, 01:30   Pomoc w projekcie WDI środek ciężkości

W istniejącym arkusza danego skoroszytu wyszukać, komórki o kolorze niebieskim - RGB(0,0,255). Dla tak zdefiniowanej figury wyznaczyć środek ciężkości. Komórkę, w której znajduje się środek ciężkości wyróżnić kolorem czerwonym- RGB(255,0,0). Wartość tej komórki ma przedstawiać wyliczone współrzędne, oddzielone spacją. Wszystkie komórki danego arkusza powinny być kwadratami. Pogrubić kontur figury.

wymagany jest tryb option explicit
nie może być private function
preferowane są zmienne jedno lub dwu znakowe
wymagana jest przynajmniej jedna funkcja

Z góry dziękuję



Bez urazy: dział w którym założyłeś wątek ma tytuł: "Mam problem z makrem". Pierwsza nasuwająca się odpowiedź to: nie masz żadnego problemu (no bo niby z jakim makrem?).
Wątek przenoszę do odpowiedniego działu.
umiejead

.
ID posta: 361189 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 351 razy
Posty: 1872
Wysłany: 24-01-2019, 04:20   

Witamy na Forum.

Cytat:
W istniejącym arkusza danego skoroszytu (...)
Skoro istnieje - to może nam go pokażesz?
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 361191 Skopiuj do schowka
 
 
Polok12344
świeżak


Posty: 3
Wysłany: 27-01-2019, 01:30   

Jest to czysty arkusz który program ma formatować tak aby komórki były kwadratami.

Kod:
Sub formatkom()
    ActiveSheet.Columns.ColumnWidth = Columns("A").ColumnWidth / Columns("A").Width * Rows(1).Height
End Sub

Takie coś napisałem i działa.

Program powinien przeszukiwać zakres $A$1:$Z$100.
Prowadzący będzie uzupełniał go losowymi figurami a reszta jest w opisie zadania.



1. Nie cytuj ostatniego posta.
2. Używaj dużych / wielkich liter.
3. Używaj znaków interpunkcyjnych.
4. Kod umieszczaj w znacznikach.
Wyjątkowo poprawiłem.
umiejead

.
ID posta: 361378 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 351 razy
Posty: 1872
Wysłany: 27-01-2019, 05:43   

A może tak:
Kod:
Option Explicit
   
Private Sub ScrollBar1_Change()
Dim w As Long, r As Double
   
On Error GoTo laEnd
   
ScrollBar1.Min = 5
ScrollBar1.Max = 100

Cells.RowHeight = ScrollBar1.Value

With Cells(1, 1)
    w = .ColumnWidth
    r = .RowHeight / .Width
    Cells.ColumnWidth = w * r
End With
   
TextBox1.Text = ScrollBar1.Value
Exit Sub

laEnd:
MsgBox "Przegiąłęś :)", vbCritical, "Info"
Cells.RowHeight = 15
Cells.ColumnWidth = 5

End Sub
?
(zakres suwaka ustawiłem na "sensowny" - ale kombinuj :mrgreen: ).

FYI: Excel ma swoje "dziwactwa" - więc efekt może odbiegać od oczekiwanego.
.

kwadratowe.xlsm
Pobierz Plik ściągnięto 22 raz(y) 21.33 KB

_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 361383 Skopiuj do schowka
 
 
Polok12344
świeżak


Posty: 3
Wysłany: 27-01-2019, 16:12   

2
Kod:
Option Explicit
Sub Centroid()
    Dim rCell As Range
    Dim lColor As Long
    Dim rColored As Range
   
    'Wybierz kolor według nazwy
    'vbBlue(opcjonalne, urzyłem funkcji rgb)
    lColor = RGB(0, 0, 255)

    'lepiej jest użyć funkcji RGB
    ', aby określić kolor
    'LColor = RGB (0, 0, 255)
   
   
   
   
     Set rColored = Nothing
    For Each rCell In Selection
        If rCell.Interior.Color = lColor Then
            If rColored Is Nothing Then
                Set rColored = rCell
            Else
                Set rColored = Union(rColored, rCell)
            End If
        End If
    Next
    If rColored Is Nothing Then
        MsgBox "No cells match the color"
    Else
        rColored.Select
       
           
           
           
           
           
   
           
    Dim oWS1 As Worksheet
   
   
     
   
    Set oWS1 = Sheet1 'Powinien to być arkusz, w którym współrzędne (x, y) są przechowywane odpowiednio w kolumnach 1 i 2 z nagłówkami.
   
    oWS1.Cells(5, 4) = rColored.Address(RowAbsolute:=False, ColumnAbsolute:=False)
   
       
    End If
    Set rCell = Nothing
    Set rColored = Nothing
   
   
    'wyszukiwanie komurek
   
   
   
   
    Dim oWS As Worksheet
    Dim vCoords As Variant
    Dim vRow() As Variant
    Dim i As Long
    Dim Area As Double
    Dim xPos As Double, yPos As Double
    Dim olska As Worksheet
    Set olska = Arkusz1
    Set oWS = Sheet1 'Powinien to być arkusz, w którym współrzędne (x, y) są przechowywane odpowiednio w kolumnach 1 i 2 z nagłówkami.
   
    'vCoords = oWS.Range(rColored.Address).Row, oWS.Cells(rColored.Address).Column
    vCoords = oWS.Range(oWS.Cells(2, 1), oWS.Cells(2, 1).End(xlDown).End(xlToRight)).Value
   
    ReDim vRow(LBound(vCoords, 2) To UBound(vCoords, 2))
   
    For i = LBound(vCoords, 2) To UBound(vCoords, 2)
        vRow(i) = vCoords(1, i)
    Next i
   
    vCoords = AddRow(vCoords, vRow)
   
    Area = CalcArea(vCoords)
   
    xPos = CalcxPos(vCoords, Area)
    yPos = CalcyPos(vCoords, Area)
   
    oWS.Cells(1, 5) = "x"
    oWS.Cells(1, 6) = "y"
    oWS.Cells(2, 4) = "Centroid:"
    oWS.Cells(2, 5) = xPos
    oWS.Cells(2, 6) = yPos
    olska.Cells(xPos, yPos).Interior.Color = RGB(255, 0, 0)
 
End Sub
 Function CalcxPos(vCoords As Variant, Area As Double) As Double
    Dim i As Long, cc As Double
   
    For i = 1 To UBound(vCoords, 1) - 1
        CalcxPos = CalcxPos + (vCoords(i, 1) + vCoords(i + 1, 1)) * (vCoords(i, 1) * vCoords(i + 1, 2) - vCoords(i + 1, 1) * vCoords(i, 2))
    Next i
   
    CalcxPos = CalcxPos / (6 * Area)
   
End Function
Private Function CalcyPos(vCoords As Variant, Area As Double) As Double
    Dim i As Long
   
    For i = 1 To UBound(vCoords, 1) - 1
        CalcyPos = CalcyPos + (vCoords(i, 2) + vCoords(i + 1, 2)) * (vCoords(i, 1) * vCoords(i + 1, 2) - vCoords(i + 1, 1) * vCoords(i, 2))
    Next i
   
    CalcyPos = CalcyPos / (6 * Area)
   
End Function
Private Function CalcArea(vCoords As Variant) As Double
    Dim i As Long
   
    For i = 1 To UBound(vCoords, 1) - 1
        CalcArea = CalcArea + vCoords(i, 1) * vCoords(i + 1, 2) - vCoords(i + 1, 1) * vCoords(i, 2)
    Next i
   
    CalcArea = 0.5 * CalcArea
   
End Function
Private Function AddRow(InputArr As Variant, vRow As Variant) As Variant
    Dim vTemp As Variant
    Dim i As Long
   
    If LBound(vRow) <> LBound(InputArr, 2) Or UBound(vRow) <> UBound(InputArr, 2) Then AddRow = 0: Exit Function
   
    vTemp = TransposeArray(InputArr)
   
    ReDim Preserve vTemp(LBound(vTemp, 1) To UBound(vTemp, 1), LBound(vTemp, 2) To UBound(vTemp, 2) + 1)
   
    vTemp = TransposeArray(vTemp)
   
    For i = LBound(vTemp, 2) To UBound(vTemp, 2)
        vTemp(UBound(vTemp, 1), i) = vRow(i)
    Next i
   
    AddRow = vTemp
   
End Function
Private Function TransposeArray(InputArr As Variant) As Variant


Dim RowNdx As Long
Dim ColNdx As Long
Dim LB1 As Long
Dim LB2 As Long
Dim UB1 As Long
Dim UB2 As Long
Dim OutputArr() As Variant


LB1 = LBound(InputArr, 1)
LB2 = LBound(InputArr, 2)
UB1 = UBound(InputArr, 1)
UB2 = UBound(InputArr, 2)


ReDim OutputArr(LB2 To LB2 + UB2 - LB2, LB1 To LB1 + UB1 - LB1)


For RowNdx = LB2 To UB2
    For ColNdx = LB1 To UB1
        OutputArr(RowNdx, ColNdx) = InputArr(ColNdx, RowNdx)
    Next ColNdx
Next RowNdx


TransposeArray = OutputArr


End Function


To co zrobiłem niestety nie działa i nie potrafię tego sklecić aby robiło cokolwiek. Wydaje mi się ,że liczenie środka ma tu sens tylko nie potrafię pozbyć się "private function" i sklecić tego w jeden program.
ID posta: 361402 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe