Копировать вставить столбец, если обнаружен определенный текст - PullRequest
0 голосов
/ 02 февраля 2020

Я написал код, но он не работает. Код должен вставить столбец перед столбцом, содержащим «X» в строке 2, и скопировать-вставить в качестве значений в столбце слева. И продолжить тот же процесс, зацикленный для других рабочих листов в рабочей книге. Я не могу запустить код. X будет в нескольких листах в разных столбцах, но всегда в строке 2. Помощь в этом будет высоко оценена. WorksheetView

  Sub insert_column()

  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.StatusBar = False

  With ThisWorkbook

  bsheets = 0

  For A = 1 To Sheets.Count

  If If Len(Sheets(A).Name) < 5 Then
  Sheets(A).Cells = Cells.Find(What:="X", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
  xlWhole, SearchOrder:=xlByColumns, MatchCase:=False_, SearchFormat:=False).Activate

    dcol = Cells(2, Columns.Count).End(xlToLeft).Column

    bsheets = bsheets + 1

    Columns(dcol).Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Columns(dcol + 1).Select
    Selection.Copy

    Columns(dcol).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

   End If

   Next A

   Exit Sub

   Application.Calculation = xlAutomatic
   Application.ScreenUpdating = True
   Application.StatusBar = True

   End With

   End Sub

1 Ответ

0 голосов
/ 02 февраля 2020
Private Sub FindX()
 Dim w As Workbook, sh As Worksheet, lastCol As Long, i As Long, valX As Variant

 Set w = ActiveWorkbook 'use here your workbook...
 For Each sh In w.Worksheets
    lastCol = sh.Cells(2, sh.Columns.count).End(xlToLeft).Column
    For i = 1 To lastCol
        If sh.Cells(2, i).Value = "X" Then
            valX = sh.Range(sh.Cells(2, 1), sh.Cells(2, lastCol)).Value
            sh.Cells(2, i).EntireColumn.Insert
            sh.Range(sh.Cells(1, i), sh.Cells(lastCol, i)).Value = WorksheetFunction.Transpose(valX)
            Exit For
        End If
    Next i
 Next
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...