VBA: Как найти отдел и заменить его другим отделом?

Мне трудно найти решение этой проблемы. Я пытаюсь найти department струн и заменить его другим отделом. В каждой книге есть 16-10 листов, для которых требуется форматирование. Один из форматов требует перемещения / копирования first department string (которая попадает в columns B,C в несколько строк) и вставляет ее, когда last department был, но первый отдел на некотором листе в columnA не имеет отдела выше это member number . Причина этого заключается в том, чтобы сделать отдел титулом.

Картинка внизу должна содержать дополнительную информацию. введите описание изображения здесь

Это то, что я до сих пор, но не соблюдаю. Я был бы признателен за помощь в этом. Пожалуйста, задавайте вопросы и дайте советы. Спасибо.

  Sub format() Dim ws As Worksheet Dim frstDept As Long Dim lastDept As Long Dim rng As Long Dim n As Long Dim nlast As Long Dim rw As Range Dim i As Integer Dim iVal As Integer iVal = Application.WorksheetFunction.CountIf(Range("A1:A20000"), "Department") Debug.Print iVal Set rw = ActiveWorkbook.ActiveSheet.UsedRange.Rows nlast = rw.Count For Each ws In Sheets On Error GoTo NextWS For i = iVal To 1 Step -1 With ws frstDept = Range("A:A").Find(What:="Department", LookIn:=xlValues, LookAt:=xlPart).Row lastDept = Range("A:A").Find(What:="Member Number", LookIn:=xlValues, LookAt:=xlPart).Row If .frstDept.Value = .lastDept.Value Then frstDept.Selection.Offset(0, 2).Cut Destination:=Range("lastDept" + 1).Resize(1) End If End If End With NextWS: Err.Clear Next ws End Sub 

Я считаю, что следующий код будет работать:

 Sub format() Dim ws As Worksheet Dim r As Long Dim lastDept As String Dim nextDept As String Dim rw As Long For Each ws In Worksheets ' Changed from "Sheets" to "Worksheets" to avoid ' problems if any "Charts" exist With ws rw = .Cells(.Rows.Count, "A").End(xlUp).Row 'Grab the details of the last "Department" and then clear the cells lastDept = RTrim(.Cells(rw, "A") & .Cells(rw, "B") & .Cells(rw, "C")) .Range("A" & rw & ":C" & rw).ClearContents For r = rw To 2 Step -1 If Trim(.Cells(r, "A").Value) = "MEMBER NUMBER" Then nextDept = RTrim(.Cells(r - 1, "A") & .Cells(r - 1, "B") & .Cells(r - 1, "C")) .Range("A" & r - 1 & ":C" & r - 1).ClearContents .Cells(r - 1, "A").Value = lastDept lastDept = nextDept End If Next End With Next ws End Sub 

Каждый раз, когда он обнаруживает «ЧИСЛО ЧЕЛОВЕКА» в столбце A, он захватывает информацию из столбцов A: C строки выше, затем очищает эти ячейки и заменяет столбец A конкатенированными значениями из предыдущего времени, когда он столкнулся с «ЧИСЛОЕМ ЧИСЛА» ». (Я предполагаю, что конкатенация столбцов A: C в одну строку – это хорошо. Если нет, я могу отредактировать ее так, чтобы значения сохранялись как отдельные строки.)


Отредактировано для поиска «Департамент» (с уверенностью, что строка 1 всегда пустая).

 Sub format() Dim ws As Worksheet Dim r As Long Dim lastDept As String Dim nextDept As String Dim rw As Long 'Initialise "lastDept" to blank so that the first replacement we make '(ie the one on the last row) is to an empty value lastDept = "" 'Loop through every worksheet 'Use "Worksheets" collection rather than "Sheets" collection so that 'we don't try to do any processing on Charts ("Sheets" contains both 'Worksheet and Chart objects) For Each ws In Worksheets 'Use a "With" block so that we don't have to constantly write '"ws.Cells", "ws.Range", "ws.Rows", etc - we can just use '".Cells", ".Range", ".Rows", etc instead With ws 'Find the end of the data by finding the last non-empty cell in column A rw = .Cells(.Rows.Count, "A").End(xlUp).Row 'Loop (backwards) through each row in the worksheet For r = rw To 1 Step -1 'We only need to process something when Column A starts with '"Department", or if this is row 1 (which will be empty) If Left(.Cells(r, "A").Value, 10) = "Department" Or r = 1 Then 'Temporarily store the current values of this row's columns A:C 'Join all three cells into one string to make it look "nicer" nextDept = RTrim(.Cells(r, "A").Value & _ .Cells(r, "B").Value & _ .Cells(r, "C").Value) 'Clear out what was in A:C .Range("A" & r & ":C" & r).ClearContents 'Write the contents of "lastDept" into column A .Cells(r, "A").Value = lastDept 'Change "lastDept" to be the value which we stored in our 'temporary variable "nextDept" (The temporary variable was 'needed because, by the time we get to this line, we have 'written over the top of the information in the worksheet 'cells.) lastDept = nextDept End If Next ' end of processing of a row End With Next ws ' end of processing of a Worksheet End Sub 

Вы устанавливаете frstDept в строку, то же самое с lastDept. Я считаю, что вы намерены вместо этого установить их в диапазон. Попробуй это:

 Sub format() Dim ws As Worksheet Dim frstDept As Range Dim lastDept As Range Dim rng As Long Dim n As Long Dim nlast As Long Dim rw As Range Dim i As Integer Dim iVal As Integer Set rw = ActiveWorkbook.ActiveSheet.UsedRange.Rows nlast = rw.Count For Each ws In Sheets ws.Activate iVal = Application.WorksheetFunction.CountIf(ws.Range("A:A"), "*Department*") Debug.Print iVal On Error GoTo NextWS For i = iVal To 1 Step -1 ' You dont have a next statement closing this for loop. With ws Set frstDept = Range("A:A").Find(What:="Department", LookIn:=xlValues, LookAt:=xlPart) Set lastDept = Range("A:A").Find(What:="Department", LookIn:=xlValues, LookAt:=xlPart) If .frstDept.Value = .lastDept.Value Then lastDept.Offset(-1, 0).Value = frstDept.Offset(1, 0).Value End If End If End With NextWS: Err.Clear Next ' This should close the for loop for your iVal iteration. Next ws End Sub 

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

Скорее всего, этот код не решит вашу проблему, но он должен приблизиться к вам. Лучше всего, чтобы ваш оператор On Error активировался каждый раз, когда вы пытались получить долью ваших переменных firstdept и lastdept, и поэтому он ничего не делал.

Надеюсь, это поможет.

Interesting Posts

Обновление документа Excel с помощью макросов

в качестве параметра, а затем использовать этот параметр как переменную

Лучший способ экспортировать данные в Excel

Скрипт VBA для автоматизации excel, нажмите «ok» в диалоговом окне

Условное форматирование Применение к диапазону вместо отдельной ячейки

Excel, Visual basic – Разделить число на заданное количество частей

Открыть файл Excel внутри окна в wpf

Таблица запросов Excel неверно форматирует веб-сайт

Excel / ADO: ошибка доступа к набору записей

Вернуть файл excel без сохранения его на сервере внутри контроллера

Попытка установить Python – пакет чтения excel

excel выполняет оператор if внутри другого оператора if

COUNTIFS с возможностью нечеткого совпадения по одному из критериев. Возможное?

Найдите значение из диапазона ячеек в столбце на многих листах и ​​верните «X» в следующий пустой столбец

VBA FormulaArray – Невозможно установить свойство FormulaArray класса Range

Давайте будем гением компьютера.