VBA Excel 2003/2007: объявление, заполнение и передача массива с зубцами. Excel vba объявление массива

vba - VBA Excel 2-мерные массивы

Здесь Общая функция VBA Array To Range, которая записывает массив на лист в одном "ударе" на листе. Это намного быстрее, чем запись данных в лист по одной ячейке за раз в циклах для строк и столбцов... Тем не менее, вам нужно провести некоторое обслуживание, так как вы должны правильно указать размер целевого диапазона.

Это "домашнее хозяйство" выглядит как большая работа, и это, вероятно, довольно медленно: но это код "последней мили" для записи на листе, и все быстрее, чем писать на рабочий лист. Или, по крайней мере, намного быстрее, чем это эффективно мгновенно, по сравнению с чтением или записью на рабочий лист, даже в VBA, и вы должны делать все, что возможно, в коде, прежде чем попадете в лист.

Важнейшим компонентом этого является улавливание ошибок, которое я привык видеть повсюду. Я ненавижу повторяющееся кодирование: я закодировал все это здесь, и, надеюсь, вам больше не придется писать.

Функция VBA 'Array to Range'

Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant) ' Write an array to an Excel range in a single 'hit' to the sheet ' InputArray must be a 2-Dimensional structure of the form Variant(Rows, Columns) ' The target range is resized automatically to the dimensions of the array, with ' the top left cell used as the start point. ' This subroutine saves repetitive coding for a common VBA and Excel task. ' If you think you won't need the code that works around common errors (long strings ' and objects in the array, etc) then feel free to comment them out. On Error Resume Next ' ' Author: Nigel Heffernan ' HTTP://Excellerando.blogspot.com ' ' This code is in te public domain: take care to mark it clearly, and segregate ' it from proprietary code if you intend to assert intellectual property rights ' or impose commercial confidentiality restrictions on that proprietary code Dim rngOutput As Excel.Range Dim iRowCount As Long Dim iColCount As Long Dim iRow As Long Dim iCol As Long Dim arrTemp As Variant Dim iDimensions As Integer Dim iRowOffset As Long Dim iColOffset As Long Dim iStart As Long Application.EnableEvents = False If rngTarget.Cells.Count > 1 Then rngTarget.ClearContents End If Application.EnableEvents = True If IsEmpty(InputArray) Then Exit Sub End If If TypeName(InputArray) = "Range" Then InputArray = InputArray.Value End If ' Is it actually an array? IsArray is sadly broken so... If Not InStr(TypeName(InputArray), "(") Then rngTarget.Cells(1, 1).Value2 = InputArray Exit Sub End If iDimensions = ArrayDimensions(InputArray) If iDimensions < 1 Then rngTarget.Value = CStr(InputArray) ElseIf iDimensions = 1 Then iRowCount = UBound(InputArray) - LBound(InputArray) iStart = LBound(InputArray) iColCount = 1 If iRowCount > (655354 - rngTarget.Row) Then iRowCount = 655354 + iStart - rngTarget.Row ReDim Preserve InputArray(iStart To iRowCount) End If iRowCount = UBound(InputArray) - LBound(InputArray) iColCount = 1 ' It a vector. Yes, I asked for a 2-Dimensional array. But I'm feeling generous. ' By convention, a vector is presented in Excel as an arry of 1 to n rows and 1 column. ReDim arrTemp(LBound(InputArray, 1) To UBound(InputArray, 1), 1 To 1) For iRow = LBound(InputArray, 1) To UBound(InputArray, 1) arrTemp(iRow, 1) = InputArray(iRow) Next With rngTarget.Worksheet Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount)) rngOutput.Value2 = arrTemp Set rngTarget = rngOutput End With Erase arrTemp ElseIf iDimensions = 2 Then iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1) iColCount = UBound(InputArray, 2) - LBound(InputArray, 2) iStart = LBound(InputArray, 1) If iRowCount > (65534 - rngTarget.Row) Then iRowCount = 65534 - rngTarget.Row InputArray = ArrayTranspose(InputArray) ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount) InputArray = ArrayTranspose(InputArray) End If iStart = LBound(InputArray, 2) If iColCount > (254 - rngTarget.Column) Then ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount) End If With rngTarget.Worksheet Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1)) Err.Clear Application.EnableEvents = False rngOutput.Value2 = InputArray Application.EnableEvents = True If Err.Number <> 0 Then For iRow = LBound(InputArray, 1) To UBound(InputArray, 1) For iCol = LBound(InputArray, 2) To UBound(InputArray, 2) If IsNumeric(InputArray(iRow, iCol)) Then ' no action Else InputArray(iRow, iCol) = "" & InputArray(iRow, iCol) InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol)) End If Next iCol Next iRow Err.Clear rngOutput.Formula = InputArray End If 'err<>0 If Err <> 0 Then For iRow = LBound(InputArray, 1) To UBound(InputArray, 1) For iCol = LBound(InputArray, 2) To UBound(InputArray, 2) If IsNumeric(InputArray(iRow, iCol)) Then ' no action Else If Left(InputArray(iRow, iCol), 1) = "=" Then InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol) End If If Left(InputArray(iRow, iCol), 1) = "+" Then InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol) End If If Left(InputArray(iRow, iCol), 1) = "*" Then InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol) End If End If Next iCol Next iRow Err.Clear rngOutput.Value2 = InputArray End If 'err<>0 If Err <> 0 Then For iRow = LBound(InputArray, 1) To UBound(InputArray, 1) For iCol = LBound(InputArray, 2) To UBound(InputArray, 2) If IsObject(InputArray(iRow, iCol)) Then InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol)) ElseIf IsArray(InputArray(iRow, iCol)) Then InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",") ElseIf IsNumeric(InputArray(iRow, iCol)) Then ' no action Else InputArray(iRow, iCol) = "" & InputArray(iRow, iCol) If Len(InputArray(iRow, iCol)) > 255 Then ' Block-write operations fail on strings exceeding 255 chars. You *have* ' to go back and check, and write this masterpiece one cell at a time... InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255) End If End If Next iCol Next iRow Err.Clear rngOutput.Text = InputArray End If 'err<>0 If Err <> 0 Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual iRowOffset = LBound(InputArray, 1) - 1 iColOffset = LBound(InputArray, 2) - 1 For iRow = 1 To iRowCount If iRow Mod 100 = 0 Then Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%" End If For iCol = 1 To iColCount rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset) Next iCol Next iRow Application.StatusBar = False Application.ScreenUpdating = True End If 'err<>0 Set rngTarget = rngOutput ' resizes the range This is useful, *most* of the time End With End If End Sub

Вам понадобится источник для ArrayDimensions:

Это объявление API требуется в заголовке модуля:

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ (Destination As Any, _ Source As Any, _ ByVal Length As Long)

... И здесь сама функция:

Private Function ArrayDimensions(arr As Variant) As Integer '----------------------------------------------------------------- ' will return: ' -1 if not an array ' 0 if an un-dimmed array ' 1 or more indicating the number of dimensions of a dimmed array '----------------------------------------------------------------- ' Retrieved from Chris Rae VBA Code Archive - http://chrisrae.com/vba ' Code written by Chris Rae, 25/5/00 ' Originally published by R. B. Smissaert. ' Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax Dim ptr As Long Dim vType As Integer Const VT_BYREF = &h5000& 'get the real VarType of the argument 'this is similar to VarType(), but returns also the VT_BYREF bit CopyMemory vType, arr, 2 'exit if not an array If (vType And vbArray) = 0 Then ArrayDimensions = -1 Exit Function End If 'get the address of the SAFEARRAY descriptor 'this is stored in the second half of the 'Variant parameter that has received the array CopyMemory ptr, ByVal VarPtr(arr) + 8, 4 'see whether the routine was passed a Variant 'that contains an array, rather than directly an array 'in the former case ptr already points to the SA structure. 'Thanks to Monte Hansen for this fix If (vType And VT_BYREF) Then ' ptr is a pointer to a pointer CopyMemory ptr, ByVal ptr, 4 End If 'get the address of the SAFEARRAY structure 'this is stored in the descriptor 'get the first word of the SAFEARRAY structure 'which holds the number of dimensions '...but first check that saAddr is non-zero, otherwise 'this routine bombs when the array is uninitialized If ptr Then CopyMemory ArrayDimensions, ByVal ptr, 2 End If End Function

Кроме того: я бы посоветовал вам сохранить эту декларацию конфиденциальной. Если вы должны сделать это публичным Sub в другом модуле, вставьте оператор Option Private Module в заголовок модуля. Вы действительно не хотите, чтобы ваши пользователи вызывали какие-либо функции с помощью CopyMemoryoperations и арифметики указателей.

qaru.site

Объявление и инициализация динамического массива листов в VBA MS Excel онлайн

В том, что вы разместили выше, было довольно много сомнительных фрагментов кода. Я пережил и переписал оскорбительные строки и включил комментарии, объясняющие, почему в приведенном ниже коде.

Это не только должно устранить вашу ошибку «вне диапазона» (поскольку вы не объявили размер вашего массива), но она исправит другие ошибки, с которыми вы еще не столкнулись (не объявляя значения переменных, перебирая каждую строку в каждом листе , не ссылаясь на объекты листа правильно, …).

Sub news() ' No need to activate sheets ' No need for array of letters for the columns: '.Cells(row,col)' can take a number for 'col' ' Integers replaced by Longs, no real incentive to use Integer type and Long can be larger ' Array of sheets: use WorkSheet objects, not a Sheets object Dim shets() As WorkSheet ' Remember to assign a value to sheetCount Dim sheetCount As Long: sheetCount = 4 ' Must declare the size of your array, this method keeps it generic ' could have used 'Dim shets(1 To 4) As WorkSheet' Dim n As Long ReDim shets(1 To sheetCount) ' Keeping with generic theme, loop over shets to define sheets, makes expanding easier For n = 1 To sheetCount ' Fully qualify sheets by using workbook object Set shets(n) = ThisWorkbook.Sheets("Sheet" & n) Next n ' Used to make sure photos goes to photos, videos to videos, and compliance to compliance Dim newShift As Long: newShift = 7 ' For loop counter variables: Must specify EACH type, 'Dim i, j, k As Long' declares i and j as Variants Dim i As Long, j As Long, k As Long ' Go through the sheets For i = 2 To sheetCount ' Go through the columns For j = 3 To 7 Step 2 ' Go through the rows. Don't just use '.Rows' object as that includes all unused rows in sheet! ' Also using one of the sheet objects, as 'ThisWorksheet' doesn't exist For k = 2 To shets(i).UsedRange.Rows.Count ' Don't access sheet objects using 'Sheets(shets(..))', simply use 'shets(..)' If shets(i - 1).Cells(k, j) = shets(i).Cells(k, j) Then shets(i).Cells(k, j + newShift).Value = False ElseIf shets(i - 1).Cells(k, j) < shets(i).Cells(k, j) Then shets(i).Cells(k, j + newShift).Value = True Else shets(i).Cells(k, j + newShift).Value = "ERROR" End If Next newShift = newShift - 1 Next Next End Sub

excel.bilee.com

vba - VBA Excel 2003/2007: объявление, заполнение и передача массива с зубцами

Я тщательно изучил эту тему и еще не нашел код, который работает, чтобы выполнить то, что мне нужно сделать. В двух словах я создаю программу отслеживания производства, и ее функция, на которой я сейчас работаю, включает точное отслеживание дней отпуска для 5 сотрудников. Пользовательская форма, содержащая 5 списков, по одному для каждого сотрудника, используется для выбора дней, в которые каждый сотрудник ушел на неделю. Проблема возникает, когда я пытаюсь создать уникальные динамические массивы, содержащие выходные дни каждого сотрудника. Я выяснил, как создать массив, который захватывает эту информацию, но это один массив, который получает переназначение каждый раз, когда цикл повторяется. Мне нужно иметь уникальный массив для каждого сотрудника, содержащего его выходные, который будет использоваться позже в коде, чтобы настроить еженедельный подсчет в зависимости от его доступных дней работы. Ниже приведен мой код в пользовательской форме для создания массива с зазубринами:

Public Name_Jagged() As Variant For Each Name In Name_Array Set Unique_Listbox = Controls(Name & "_Vacation") For UnSelected = 0 To Unique_Listbox.ListCount - 1 If Unique_Listbox.Selected(UnSelected) = False Then ReDim Preserve Name_Jagged(0 To UBound(Name_Jagged) + 1) Name_Array(Name) = Name_Jagged() Name_Jagged(UBound(Name_Jagged)) = Unique_Listbox.List(UnSelected) End If For UnSelected_Array_Pos = LBound(Name_Jagged) To UBound(Name_Jagged) MsgBox Name & "_" & Name_Jagged(UnSelected_Array_Pos) Next UnSelected_Array_Pos Next UnSelected Next Name

Компилятор не позволит мне использовать Public Name_Jagged()() как вариант либо несмотря на то, что большинство других форумов говорят, что это то, как оно должно быть написано. Единственное сообщение, которое я нашел в Интернете по поводу этой проблемы с объявлением массива, не получил ответа.

Я бы очень признателен вам за вашу помощь. Мне удалось выяснить все, что осталось от предыдущих тем, но это ускользнуло от меня. Если для этого есть лучший вариант, чем зубчатые массивы, я все уши. Я читал на некоторых форумах об использовании списков, но я ничуть не знаком с ними или как их использовать на данный момент. Заранее спасибо за помощь.

qaru.site

vba - Переменный массив Excel VBA

У меня есть проект, в котором я должен извлечь строки, относящиеся к конкретному SKU, и обработать его и сохранить на новом листе.

Поэтому из исходного набора строк и столбцов я выбираю строки и столбцы и сохраняю их в массиве переменных. Поскольку различные столбцы имеют различные типы данных, от целочисленного до строкового в html-коды.

Вот макрос, который я написал. Хотя я работаю так, как я ожидаю, я чувствую, что делаю это неправильно.

объявление массива
использование массива и
очистка массива перед загрузкой новых данных следующего SKU

Я был бы рад, если бы кто-то мог помочь мне в том, как я могу это сделать. cos прямо сейчас я объявляю большой набор массива, хотя знаю, что данные не будут такими огромными.

Sub fastcloudextractor() ' ' fastcloud extractor Macro ' ' defenitions Dim data_arr() As Variant, temp_arr() As Variant Dim i As Long, j As Long, k As Long, curent_item As Long Dim pctCompl As Integer, err As Integer, total_items As Integer Application.ScreenUpdating = False err = 2 ' ' get data row count and load data into array ' Sheets("Original").Select data_count = Range("A1").End(xlDown).Row data_count = data_count + 1 Cells(data_count, 1) = 1 Cells(data_count, 5) = 1 data_arr = Range(Cells(2, 5), Cells(data_count, 14)) ' ' get itemcode row count and load item codes into array ' ' Sheets("Unique").Select ' item_count = Range("A1").End(xlDown).Row ' item_arr = Range(Cells(2, 1), Cells(item_count, 1)) ' It is these two lines without which the macro gives a error ' Sheets("sheet4").Select temp_arr = Range(Cells(1, 1), Cells(data_count, 10)) ' ----- Begin new code ----- k = 1 current_item = data_arr(1, 1) ' Debug.Print current_item For j = LBound(data_arr) To UBound(data_arr) If data_arr(j, 1) = current_item Then ' copy Row values to new array temp_arr(k, 1) = data_arr(j, 1) temp_arr(k, 2) = data_arr(j, 2) temp_arr(k, 3) = data_arr(j, 3) temp_arr(k, 4) = data_arr(j, 4) temp_arr(k, 5) = data_arr(j, 5) temp_arr(k, 6) = data_arr(j, 6) temp_arr(k, 7) = data_arr(j, 7) temp_arr(k, 8) = data_arr(j, 8) temp_arr(k, 9) = data_arr(j, 9) temp_arr(k, 10) = data_arr(j, 10) Else total_items = total_items + 1 ' manipulate temp array ' write single item data to Seelcted Sheet. Sheets("Selected").Select Range("A2").Resize(UBound(data_arr, 1), UBound(data_arr, 2)) = temp_arr ' Do some processing of the data ' reset item array counter to first line k = 1 ' copy the current row to temp array current_item = data_arr(j, 1) temp_arr(k, 1) = data_arr(j, 1) temp_arr(k, 2) = data_arr(j, 2) temp_arr(k, 3) = data_arr(j, 3) temp_arr(k, 4) = data_arr(j, 4) temp_arr(k, 5) = data_arr(j, 5) temp_arr(k, 6) = data_arr(j, 6) temp_arr(k, 7) = data_arr(j, 7) temp_arr(k, 8) = data_arr(j, 8) temp_arr(k, 9) = data_arr(j, 9) temp_arr(k, 10) = data_arr(j, 10) End If k = k + 1 Next j Erase temp_arr Erase data_arr Sheets("Original").Select Range("A2:N2").Select Sheets("Unique").Select Range("A2").Select Sheets("Selected").Select Range("A1").Select Sheets("Compiled").Select Range("A2").Select Sheets("Extracted").Select Range("A1").Select Sheets("Magmi").Select Application.ScreenUpdating = True Application.StatusBar = False Beep MsgBox "Data Conversion Completed" & vbCr & "Total no of products is .." & total_items End Sub

Я предварительно назначаю пустой пул из пустого листа, чтобы заставить массив работать в нижних строках кода

' It is these two lines without which the macro gives a error ' Sheets("sheet4").Select temp_arr = Range(Cells(1, 1), Cells(data_count, 10))

Я думаю, что массив temp должен быть динамическим и переменным, и мне не нужно назначать полный набор данных в массив, который является тихим большим потребителем памяти

любая помощь и помощь оцениваются.

qaru.site

объявление, заполнение и передача массива с зубцами MS Excel онлайн

Я тщательно изучил эту тему и еще не нашел код, который работает, чтобы выполнить то, что мне нужно сделать. В двух словах я создаю программу отслеживания производства, и ее функция, на которой я сейчас работаю, включает точное отслеживание дней отпуска для 5 сотрудников. Пользовательская форма, содержащая 5 списков, по одному для каждого сотрудника, используется для выбора дней, в которые каждый сотрудник ушел на неделю. Проблема возникает, когда я пытаюсь создать уникальные динамические массивы, содержащие выходные дни каждого сотрудника. Я понял, как создать массив, который захватывает эту информацию, но это один массив, который получает переназначение каждый раз, когда цикл повторяется. Мне нужно иметь уникальный массив для каждого сотрудника, содержащего его выходные, который будет использоваться позже в коде, чтобы настроить еженедельный подсчет в зависимости от его доступных дней работы. Ниже приведен мой код в пользовательской форме для создания массива с зазубринами:

Компилятор не позволит мне использовать Public Name_Jagged () () как вариант либо, несмотря на большинство других форумов, говорящих, что это то, как это должно быть написано. Единственное сообщение, которое я нашел в Интернете по поводу этой проблемы с объявлением массива, не получил ответа.

Solutions Collecting From Web of "VBA Excel 2003/2007: объявление, заполнение и передача массива с зубцами"

Просто мысль, но почему у вас есть 5 статических списков для каждого сотрудника? Почему бы не просто иметь 1 список, в котором указаны имена сотрудников и 1 список, в котором указаны дни недели. Вы выделяете сотрудника, которого хотите, и выберите дни, которые они сняли. Нажмите кнопку отправки, которая будет загружать имя сотрудников в массив с выбранными днями? Массив может быть структурирован таким образом

JIM ….. OFF ………… OFF

ERIC ………………….. OFF …………. OFF

И так далее. Таким образом, если вам нужно добавить людей в будущем, вы просто добавите их в список. Вы могли бы иметь один простой массив?

Также вы сказали, что «будут использоваться позже в коде для корректировки еженедельного подсчета очков в зависимости от его доступных дней работы»

Предложение; Вы можете захотеть записать его в простую базу данных mysql / mssql, которая дает вам большую гибкость и контроль в будущем.

excel.bilee.com