Как мне скопировать все данные, размером не более 72 символов, в новую рабочую книгу?

Question

Мне нужно загрузить из Excel в SAP.

Активная рабочая книга содержит столбцы H, I, J, M и N.

SAP распознает только текст длиной не более 72 букв.Столбцы от H до J и M никогда не будут иметь более 72 букв.

С

До

Создание новой рабочей книги и сохранение в качестве имени.

Копирование H, I, J, M и N из активной рабочей книги в новую рабочую книгу в A, B, C, D, E.

Если текст в N содержит больше букв, чем 72, создайте новую строку в новой рабочей книге с той же информацией в диапазоне от A до D и продолжите текст от N после 72 букв из активной строки.

Продолжайте процедуру, пока полный текст из E не будет теперь разделен на строки из 72 букв.

Sub Copy_Value_ofBox()

Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.ActiveSheet
Dim lngLastRow As Long: lngLastRow = ws.UsedRange.Rows.Count

'eine neue Datei erstellen / create new workbook with Filename

Set wb = Workbooks.Add

With wb
.SaveAs Filename:="C:\Users\X1YKapla\Desktop\Yunus Kaplan\02 
Tätigkeiten\011 Translation\02 Upload Files\Translation 
Upload Language___ and Date___.xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

'.SaveAs Filename:= Source - wo soll es gespeichert werden und nach dem     
backslash Datei name zb. "JAN 2012.xlsx" _
   , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

wb("Translation Upload Language___ and Date___.xlsm").ws.Range("H1:J1").Copy 
_ wb("Kopie von Template_Translation").ws.Range("A1")

.ChangeFileAccess Mode:=xlReadOnly, WritePassword:="Translation"

End With

'Übersetzte texte - Copy Title in new Workbook

ws.Range("H1").Copy Destination:=ws.Range("A1")
ws.Range("I1").Copy Destination:=ws.Range("B1")
ws.Range("J1").Copy Destination:=ws.Range("C1")
ws.Range("M1").Copy Destination:=ws.Range("D1")
ws.Range("N1").Copy Destination:=ws.Range("E1")

Application.CutCopyMode = False

End Sub

Мне удалось создать новый файл и сохранить его как имя.

Я не смог скопировать данные из активного wb в новый wb.

Answer 1

Объяснение в комментариях к коду.

Option Explicit

Sub MakeSAPws()

    Dim fn As String, str As String, i As Long, j As Long, p As Long, mxt As Long, tmp As Variant

    fn = "C:\Users\X1YKapla\Desktop\Yunus Kaplan\02 Tätigkeiten\011 Translation\02 Upload Files\Translation Upload Language___ and Date___"
    mxt = 72   'maximum text length

    'when you copy a worksheet without a destination it creates a new
    'workbook with a copy of that worksheet
    ActiveSheet.Copy

    With ActiveWorkbook

        'save as filename assigned above
        .SaveAs Filename:=fn, FileFormat:=xlOpenXMLWorkbookMacroEnabled

        'there is only one worksheet
        With .Worksheets(1)

            'optionally change new worksheet name
            .Name = "blah-blah"

            'delete unwanted columns
            .Range("A:G, K:L, O:XFD").EntireColumn.Delete

            'loop through rows backwards splitting column N
            For i = .Cells(.Rows.Count, "E").End(xlUp).Row To 1 Step -1
                'reset p
                p = mxt
                'assign column N to str
                str = .Cells(i, "E").Value
                'make pieces of column N split on spaces less than 72 chars
                Do While p < Len(str)
                    p = InStrRev(str, Chr(32), p, vbBinaryCompare)
                    str = Application.Replace(str, p, 1, Chr(9))
                    p = p + mxt
                Loop
                'create array of column N pieces
                tmp = Split(str, Chr(9))
                'create additional rows if required
                For j = UBound(tmp) To LBound(tmp) + 1 Step -1
                    .Cells(i + 1, "A").Resize(1, 5).Insert shift:=xlDown
                    .Cells(i + 1, "E") = tmp(j)
                    .Cells(i, "A").Resize(2, 4).FillDown
                    .Cells(i, "E") = tmp(LBound(tmp))
                Next j
            Next i

        End With

        .ChangeFileAccess Mode:=xlReadOnly, WritePassword:="Translation"
        .Close savechanges:=True

    End With

End Sub

Answer 2

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

dim wbs as workbook, wbd as workbook
set wbs = activeworkbook 'workbook: source
set wbd = createobject("Excel.Application") 'workbook: destination

Затем вы можете использовать извлечение данных из одного и подталкивание в другое. Это будет отличаться от save as, который имеет только одну рабочую книгу, но меняет расположение пути к файлу.

---

Что касается перемещения ваших данных, используйте значение = значение для ускорения вашего процесса, например:

wbd.range(wbd.columns(1),wbd.columns(3)).value = wbs.range(wbs.columns(8),wbs.columns(10)).value