Pamiętaj, że jeśli piszesz:
MyArray = Range("A1:A5000")
jesteś naprawdę pisanie
MyArray = Range("A1:A5000").Value
Można również użyć nazwy:
MyArray = Names("MyWSTable").RefersToRange.Value
ale ich jakość nie jest jedyną właściwością Rozpiętość . Użyłem:
MyArray = Range("A1:A5000").NumberFormat
Wątpię
MyArray = Range("A1:A5000").Font
będzie działać, ale spodziewałbym
MyArray = Range("A1:A5000").Font.Bold
do pracy.
Nie wiem, jakie formaty chcesz skopiować, więc będziesz musiał spróbować.
Muszę jednak dodać, że podczas kopiowania i wklejania dużego zakresu nie jest to aż tak powolne, jak w przypadku macierzy, jak wszyscy myśleliśmy.
post Edytuj informacje
Po pisał wyżej Próbowałem przez własną poradę. Moje eksperymenty z kopiowaniem Font.Color i Font.Bold do tablicy nie powiodły się.
z poniższych stwierdzeń, drugi zawiedzie z niedopasowania typu:
ValueArray = .Range("A1:T5000").Value
ColourArray = .Range("A1:T5000").Font.Color
ValueArray musi być wariantu typu. Próbowałem ColourArray zarówno wariant jak i długo bez powodzenia.
Napełniłem ColourArray wartościami i próbował następującą informację:
.Range("A1:T5000").Font.Color = ColourArray
Cały zakres będzie kolorowy według pierwszego elementu ColourArray a następnie Excel cyrkulowanymi spożywania około 45% czasu procesora, dopóki nie zakończono to za pomocą Menedżera zadań.
Istnieje pewna kara czasowa związana z przełączaniem między arkuszami, ale ostatnie pytania dotyczące czasu trwania makra sprawiły, że wszyscy przekonali się, że praca z tablicami była znacznie szybsza.
Skonstruowałem eksperyment, który zasadniczo odzwierciedla twoje wymagania. Wypełniłem arkusz roboczy Czas1 5000 rzędami po 20 komórek, które zostały wybiórczo sformatowane jako: pogrubienie, kursywa, podkreślenie, indeks dolny, obramowanie, czerwony, zielony, niebieski, brązowy, żółty i szary - 80%.
W wersji 1 skopiowałem co 7th komórek z arkusza roboczego "Czas1" do arkusza roboczego "Czas2" za pomocą kopii.
W wersji 2 skopiowałem co 7th komórek z arkusza roboczego "Czas1" do arkusza roboczego "Czas2", kopiując wartość i kolor za pomocą tablicy.
W wersji 3 skopiowałem co 7 komórki z arkusza roboczego "Czas1" do arkusza roboczego "Czas2", kopiując formułę i kolor za pomocą tablicy.
Wersja 1 zajęła średnio 12,43 sekund, wersja 2 zajęła średnio 1,47 sekundy, podczas gdy wersja 3 zajęła średnio 1,83 sekundy. Wersja 1 skopiowała formuły i całe formatowanie, wersja 2 skopiowała wartości i kolor, natomiast wersja 3 skopiowała formuły i kolor. W wersjach 1 i 2 możesz dodać pogrubienie i kursywa, powiedzmy, i nadal mieć trochę czasu. Nie jestem jednak pewien, czy warto było się tym przejmować, ponieważ kopiowanie 21 300 wartości zajmuje tylko 12 sekund.
** Kod dla wersji 1 **
Nie sądzę, kod ten zawiera niczego, co wymaga wyjaśnienia. Odpowiedz z komentarzem, jeśli się mylę i naprawię.
Sub SelectionCopyAndPaste()
Dim ColDestCrnt As Integer
Dim ColSrcCrnt As Integer
Dim NumSelect As Long
Dim RowDestCrnt As Integer
Dim RowSrcCrnt As Integer
Dim StartTime As Single
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
NumSelect = 1
ColDestCrnt = 1
RowDestCrnt = 1
With Sheets("Time2")
.Range("A1:T715").EntireRow.Delete
End With
StartTime = Timer
Do While True
ColSrcCrnt = (NumSelect Mod 20) + 1
RowSrcCrnt = (NumSelect - ColSrcCrnt)/20 + 1
If RowSrcCrnt > 5000 Then
Exit Do
End If
Sheets("Time1").Cells(RowSrcCrnt, ColSrcCrnt).Copy _
Destination:=Sheets("Time2").Cells(RowDestCrnt, ColDestCrnt)
If ColDestCrnt = 20 Then
ColDestCrnt = 1
RowDestCrnt = RowDestCrnt + 1
Else
ColDestCrnt = ColDestCrnt + 1
End If
NumSelect = NumSelect + 7
Loop
Debug.Print Timer - StartTime
' Average 12.43 secs
Application.Calculation = xlCalculationAutomatic
End Sub
** Kod dla wersji 2 i definicji typu 3 **
użytkownik musi być umieszczony przed każdym podprogramie w module. Kod działa poprzez kopiowanie wartości lub formuł i kolorów w arkuszu źródłowym do następnego elementu tablicy. Po zakończeniu selekcji kopiuje zebrane informacje do arkusza docelowego. Dzięki temu unika się konieczności przełączania między arkuszami roboczymi bardziej niż jest to konieczne.
Type ValueDtl
Value As String
Colour As Long
End Type
Sub SelectionViaArray()
Dim ColDestCrnt As Integer
Dim ColSrcCrnt As Integer
Dim InxVLCrnt As Integer
Dim InxVLCrntMax As Integer
Dim NumSelect As Long
Dim RowDestCrnt As Integer
Dim RowSrcCrnt As Integer
Dim StartTime As Single
Dim ValueList() As ValueDtl
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' I have sized the array to more than I expect to require because ReDim
' Preserve is expensive. However, I will resize if I fill the array.
' For my experiment I know exactly how many elements I need but that
' might not be true for you.
ReDim ValueList(1 To 25000)
NumSelect = 1
ColDestCrnt = 1
RowDestCrnt = 1
InxVLCrntMax = 0 ' Last used element in ValueList.
With Sheets("Time2")
.Range("A1:T715").EntireRow.Delete
End With
StartTime = Timer
With Sheets("Time1")
Do While True
ColSrcCrnt = (NumSelect Mod 20) + 1
RowSrcCrnt = (NumSelect - ColSrcCrnt)/20 + 1
If RowSrcCrnt > 5000 Then
Exit Do
End If
InxVLCrntMax = InxVLCrntMax + 1
If InxVLCrntMax > UBound(ValueList) Then
' Resize array if it has been filled
ReDim Preserve ValueList(1 To UBound(ValueList) + 1000)
End If
With .Cells(RowSrcCrnt, ColSrcCrnt)
ValueList(InxVLCrntMax).Value = .Value ' Version 2
ValueList(InxVLCrntMax).Value = .Formula ' Version 3
ValueList(InxVLCrntMax).Colour = .Font.Color
End With
NumSelect = NumSelect + 7
Loop
End With
With Sheets("Time2")
For InxVLCrnt = 1 To InxVLCrntMax
With .Cells(RowDestCrnt, ColDestCrnt)
.Value = ValueList(InxVLCrnt).Value ' Version 2
.Formula = ValueList(InxVLCrnt).Value ' Version 3
.Font.Color = ValueList(InxVLCrnt).Colour
End With
If ColDestCrnt = 20 Then
ColDestCrnt = 1
RowDestCrnt = RowDestCrnt + 1
Else
ColDestCrnt = ColDestCrnt + 1
End If
Next
End With
Debug.Print Timer - StartTime
' Version 2 average 1.47 secs
' Version 3 average 1.83 secs
Application.Calculation = xlCalculationAutomatic
End Sub
Chociaż mogłem obliczyć zakres, z którego komórki, z których kopiuję, nie znajdują się w zakresie. Kod przeszukuje arkusze mnożenia dla danego kryterium, jeśli znajdzie wiersz, który spełnia kryteria, z jaką kopiuje określoną komórkę z tego wiersza do arkusza wynikowego. Tak więc, podczas gdy wyjściowy rząd będzie wciskał każdą pętlę o 1. wartość dla sheets_, a wiersz wejściowy będzie losowy, a jak powiedziano będzie tysiące. I tak, baza danych byłaby drogą do zrobienia, ale w tej chwili nie jest to możliwe. – DevilWAH
Postaram się, że wydaje się to dobrą możliwością. drugą alternatywą jest skopiowanie ich do tablicy i sprawdzenie koloru czcionki i skopiowanie do drugiego elementu. Posiadanie ich w szyku pozwoliłoby mi przeprowadzić inne rzeczy. – DevilWAH
PS co powiesz na pytanie, czy potrzebujesz zbudować zasięg na wielu arkuszach? – DevilWAH