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
ID tematu: 63732 Skopiuj do schowka I i II półrocze z daty
Autor Wiadomość
hand1 
Exceloholic


Posty: 144
Wysłany: 08-01-2019, 20:38   I i II półrocze z daty

Witam wszystkich
Dzięki Waszej pomocy funkcjonuje mi makro wyciągające miesiące i kwartały z dat. Zaistniała potrzeba wyciągnięcia I i II półrocza. Tabela przestawna w tym przypadku mi nie pomoże. Excel 2010. Proszę o pomoc.
Makro:
Kod:
Sub Przenies()

 Dim miesiac As Integer, OstWArk As Long
 Dim kom As Range, zakres As Range
 Dim Ark As Worksheet, OstW As Long, flara As Boolean


 For Each Ark In ThisWorkbook.Worksheets
     If Ark.Name <> "OGÓŁEM" Then
         OstWArk = Ark.Cells(Ark.Rows.Count, "B").End(xlUp).Row
         If OstWArk > 1 Then Ark.Range("B2:O" & OstWArk).Clear
     End If
 Next Ark

 With ThisWorkbook.Worksheets("OGÓŁEM")

 OstW = .Cells(.Rows.Count, "B").End(xlUp).Row

 Set zakres = .Range("E2:E" & OstW)

 For Each kom In zakres
     If kom <> "" Then
         miesiac = Month(kom)
         For Each Ark In ThisWorkbook.Worksheets
             If UCase(Ark.Name) = UCase(MonthName(miesiac)) Or UCase(Ark.Name) = WorksheetFunction.Roman(DatePart("q", kom)) & "_KWARTAŁ" Then
                 OstWArk = Ark.Cells(Ark.Rows.Count, "B").End(xlUp).Row
                 kom.Offset(, -3).Resize(1, 9).Copy Ark.Cells(OstWArk + 1, 2)
                 flara = True
             End If
         Next Ark
     End If
 If flara = False Then kom.Interior.Color = vbRed
 flara = False
 Next kom
                 
 Set zakres = Nothing

 End With

 End Sub


baza_problem.rar
Pobierz Plik ściągnięto 11 raz(y) 76.97 KB

ID posta: 360017 Skopiuj do schowka
 
 
Tajan


Pomógł: 4286 razy
Posty: 9527
Wysłany: 08-01-2019, 22:16   

Przykładowo, można tak:
Kod:
Sub Przenies()

 Dim miesiac As String, kwartal As String, polrocze As String
 Dim OstWArk As Long
 Dim kom As Range, zakres As Range
 Dim Ark As Worksheet, OstW As Long, flara As Boolean


 For Each Ark In ThisWorkbook.Worksheets
     If Ark.Name <> "OGÓŁEM" Then
         OstWArk = Ark.Cells(Ark.Rows.Count, "B").End(xlUp).Row
         If OstWArk > 1 Then Ark.Range("B2:O" & OstWArk).Clear
     End If
 Next Ark

 With ThisWorkbook.Worksheets("OGÓŁEM")

 OstW = .Cells(.Rows.Count, "B").End(xlUp).Row

 Set zakres = .Range("E2:E" & OstW)

 For Each kom In zakres
     If kom <> "" Then
         
         miesiac = UCase(MonthName(Month(kom)))
         kwartal = WorksheetFunction.Roman(DatePart("q", kom))
         polrocze = IIf(kwartal = "I" Or kwartal = "II", "I", "II") & "_PÓŁROCZE"
         kwartal = kwartal & "_KWARTAŁ"
         
         For Each Ark In ThisWorkbook.Worksheets
             If UCase(Ark.Name) = miesiac Or UCase(Ark.Name) = kwartal Or UCase(Ark.Name) = polrocze Then
                 OstWArk = Ark.Cells(Ark.Rows.Count, "B").End(xlUp).Row
                 kom.Offset(, -3).Resize(1, 9).Copy Ark.Cells(OstWArk + 1, 2)
                 flara = True
             End If
         Next Ark
     End If
 If flara = False Then kom.Interior.Color = vbRed
 flara = False
 Next kom
                 
 Set zakres = Nothing

 End With

 End Sub
ID posta: 360023 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1164 razy
Posty: 3483
Wysłany: 08-01-2019, 22:58   

Dopisałem pare linii do Twojego kodu.
Kod:
Sub Przenies()
    Dim sh As Excel.Worksheet
    Dim k As Integer
    Dim miesiac As Integer, OstWArk As Long, i As Long, j As Long
    Dim a
    Dim kom As Range, zakres As Range
    Dim Ark As Worksheet, OstW As Long, flara As Boolean


     For Each Ark In ThisWorkbook.Worksheets
         If Ark.Name <> "OGÓŁEM" Then
             OstWArk = Ark.Cells(Ark.Rows.Count, "B").End(xlUp).Row
             If OstWArk > 1 Then Ark.Range("B2:O" & OstWArk).Clear
         End If
     Next Ark
     With ThisWorkbook.Worksheets("OGÓŁEM")
         OstW = .Cells(.Rows.Count, "B").End(xlUp).Row
         Set zakres = .Range("E2:E" & OstW)
            For Each kom In zakres
                If kom <> "" Then
                    miesiac = Month(kom)
                    For Each Ark In ThisWorkbook.Worksheets
                        If UCase(Ark.Name) = UCase(MonthName(miesiac)) Or UCase(Ark.Name) = WorksheetFunction.Roman(DatePart("q", kom)) & "_KWARTAŁ" Then
                            OstWArk = Ark.Cells(Ark.Rows.Count, "B").End(xlUp).Row
                            kom.Offset(, -3).Resize(1, 9).Copy Ark.Cells(OstWArk + 1, 2)
                            flara = True
                        End If
                    Next Ark
                End If
                If flara = False Then kom.Interior.Color = vbRed
                flara = False
            Next kom
     '---------- moja dopiska -----------------------
         a = [{"I", "II","III","IV"}]
        For i = 1 To 4
           Set sh = Worksheets(a(i) & "_kwartał")
           b = Int(i / 3) + 1
           With sh.Range("B2").CurrentRegion
               .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy _
                       Sheets(a(b) & "_półrocze").Range("B" & Rows.Count).End(xlUp)(2)
           End With
        Next
        Set zakres = Nothing
        Set sh = Nothing
   
     End With
 End Sub
Pozdrawiam.
ID posta: 360031 Skopiuj do schowka
 
 
hand1 
Exceloholic


Posty: 144
Wysłany: 09-01-2019, 19:01   

Witam
Makro Tajana działa wyśmienicie.
Kuma, w Twoim dopisku do makra wkradł się chyba błąd bo zatrzymuje się na linii 40,col 12
Kod:
b = Int(i / 3) + 1

Dwa różne ciekawe rozwiązania.
Myślę,że temat można zamknąć. Dziękuję za pomoc.
ID posta: 360117 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1164 razy
Posty: 3483
Wysłany: 09-01-2019, 19:10   

Nie wiem dlaczego nie ma deklaracji tej zmiennej. Jakoś się wykasowała. Wystarczy dodać w części deklaracji
Kod:
dim b as Integer
Pozdrawiam.
ID posta: 360121 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