переменных поиске ячейки VBA

Question

У меня есть следующий столбец (1):

1 
15 
150 
    1500000 
     06700 
     07290 
     07500 
2 
22 
220 
    2200000 
     00900 

Для этого потребуется, чтобы стать 2 колонки

1 
15 
150 
1500000  06700 
1500000  07290 
1500000  07500 
2 
22 
220  
2200000  00900 

Моя первоначальная идея:

• Создать дополнительный колонка.
• Цитирование через строки, регистр ячейки и значение в переменных, когда число с длиной в 7 цифр найдено.
• Передвигайте значения под ним на колонке B, пока длина значений не <> 5
• Старт из клетки, сохраненной в переменной и скопировать значение из переменной в колонке А пока колонка А больше не пустой
• После выше proces, loop rows и delete, где A - длина 7, а B - пустая.

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

Этот код должен запускаться каждый месяц в новом большом файле Excel.

Answer 1

ли ваши 5 цифр (в/ш/ведущих нулей) числа являются истинные номера с форматированием ячейки 00000 или текстом Сущего просмотровым как-номер с Range.PrefixCharacter property, то Range.Text property должен быть в состоянии определить, их обрезанная длина от отображаемого текста.

Следующий код следует за вашими логическими шагами с несколькими изменениями; наиболее очевидным является то, что он идет от нижней части колонны А до вершины. Это делается для того, чтобы избежать пропусков строк, которые были удалены.

Sub bringOver() 
    Dim rw As Long, v As Long, vVAL5s As Variant, vREV5s As Variant 

    'put the cursor anywhere in here and start tapping F8 
    'it will help if you can also see the worksheet with your 
    'sample data 

    ReDim vVAL5s(0) 'preset some space for the first value 

    With Worksheets("Sheet1") '<~~ set this worksheet reference properly! 
     'ensure a blank column B 
     .Columns(2).Insert 

     'work from the bottom to the top when deleting rows 
     'or you risk skipping a row 
     For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 
      'determine the length of the trimmed displayed length 
      'and act accordingly 
      Select Case Len(Trim(.Cells(rw, 1).Text)) 
       Case Is < 5 
        'do nothing 
       Case 5 
        'it's one to be transferred; collect it 
        vVAL5s(UBound(vVAL5s)) = .Cells(rw, 1).Text 
        'make room for the next 
        ReDim Preserve vVAL5s(UBound(vVAL5s) + 1) 
       Case 7 
        'only process the transfer if there is something to transfer 
        If CBool(UBound(vVAL5s)) Then 
         'the array was built from the bottom to the top 
         'so reverse the order in the array 
         ReDim vREV5s(UBound(vVAL5s) - 1) 
         For v = UBound(vVAL5s) - 1 To LBound(vVAL5s) Step -1 
          vREV5s(UBound(vREV5s) - v) = vVAL5s(v) 
         Next v 
         'working With Cells is like selecting htem but without selecting them 
         'want to work With a group of cells tall enough for all the collected values 
         With .Cells(rw, 1).Resize(UBound(vREV5s) + 1, 1) 
          'move over to column B and put the values in 
          .Offset(0, 1) = Application.Transpose(vREV5s) 
          'make sure they show leading zeroes 
          .Offset(0, 1).NumberFormat = "[Color13]00000;[Color9]@" 
          'if there was more than 1 moved over, FillDown the 7-wide value 
          If CBool(UBound(vREV5s)) Then .FillDown 
          'delete the last row 
          .Cells(.Rows.Count + 1, 1).EntireRow.Delete 
         End With 
         'reset the array for the next first value 
         ReDim vVAL5s(0) 
        End If 
       Case Else 
        'do nothing 
      End Select 
      'move to the next row up and continue 
     Next rw 
     'covert the formatted numbers to text 
     Call makeText(.Columns(2)) 
    End With 
End Sub 

Sub makeText(rng As Range) 
    Dim tCell As Range 
    For Each tCell In rng.SpecialCells(xlCellTypeConstants, xlNumbers) 
     tCell.Value = Format(tCell.Value2, "\'00000;@") 
    Next tCell 
End Sub 

Незадолго до выхода из основной подпрограммы короткий вспомогательный вспомогательный вызов вызывается с использованием столбца B в виде диапазона ячеек.Это будет проходить через все числа в столбце B и преобразовывать числа в текст с ведущими нулями.

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

Answer 2

После написания логики, имея в виду, вход Jeeped, я в конечном итоге сделать это следующим образом:

• Force преобразовать столбец A в текст, безусловно, будет
• Создать дополнительный столбец.
• Получить количество строк с данными
• Loop 1: Если столбец Клетка длина составляет 5, переместить ячейку в столбце В
• Loop 2: Если в колонке Клетка длина составляет 7, мы копируем значение переменной.
• Loop 2: Если длина ячейки ячейки A равна 0, мы вставляем переменную в ячейку
• После того, как описанные выше процессы, строки цикла и delete, где A - длина 7, а B пусто. (обратная петля для работы)

Все данные на ниже представленном коде более чем приветствуются. Я открыт для любой возможной оптимизации.

Sub FixCols() 

    'First trim the numbers (text) with 2 methods. VBA trim and Worksheet formula trim 
     Range("A:A").NumberFormat = "@" 

     Dim Cell As Range 
     For Each Cell In ActiveSheet.UsedRange.Columns("A").Cells 
      x = x + 1 
      Cell = Trim(Cell) 
      Cell.Value = WorksheetFunction.Trim(Cell.Value) 
     Next 

    'Now insert empty column as B 
     Columns("B:B").Select 
     Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 

    'Determine rows with values for loop 
     With ActiveSheet 
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
     End With 

    'Loops to move around the data 

    Dim i As Long 
    Dim CellValue As Long 

     For i = 1 To LastRow 
     'move items to column B 
      If Len(Range("A" & i).Value) = 5 Then 
       Range("A" & i).Select 
       Selection.Cut 
       Range("B" & i).Select 
       ActiveSheet.Paste 
      End If 
     Next i 

     For i = 1 To LastRow 
      'if the row is a reknr we copy the value 
      If Len(Range("A" & i).Value) = 7 Then 
       CellValue = Range("A" & i).Value 
      End If 
      'Paste the reknr to the rows with item 
      If Len(Range("A" & i).Value) = 0 Then 
       Range("A" & i).Value = CellValue 
      End If 
     Next i 

    'Reverse loop (performance) to check for rows to delete (reknr without item) 
     i = LastRow 
     Do 
      If Len(Range("A" & i).Value) = 7 And Len(Range("B" & i).Value) = 0 Then 
       Rows(i).Delete 
      End If 
      i = i - 1 
     Loop While Not i < 1 

    End Sub