Excel 如何将所有数据（单元格限制为72个字符）复制到新工作簿中？

我需要从Excel上传到SAP

活动工作簿有H、I、J、M和N列

SAP仅识别最大长度为72个字母的文本。从H到J和M的列的字母数不得超过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

从

到

创建新工作簿并另存为名称

将活动工作簿中的H、I、J、M和N复制到新工作簿中的A、B、C、D、E

当N中的文本包含的字母数超过72个时，请在新工作簿中使用范围A到D的相同信息创建新行，并在活动行中的72个字母后继续N中的文本

继续此过程，直到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。

您需要同时声明旧工作簿和新工作簿，以便随时在它们之间进行交换。示例代码为：

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

然后，您可以利用从一个数据库中提取数据并将其推送到另一个数据库中。这与只有一个工作簿但更改文件路径位置的另存为不同

---

关于移动数据，请使用value=value来加快流程，以便：

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

---

代码注释中的解释

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

选项显式
子MakeSAPws（）
Dim fn为字符串，str为字符串，i为长，j为长，p为长，mxt为长，tmp为变体
fn=“C:\Users\X1YKapla\Desktop\Yunus Kaplan\02 Tätigkeiten\011 Translation\02 Upload Files\Translation Upload Language\uuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuu
mxt=72'最大文本长度
'当复制没有目标的工作表时，它会创建一个新的目标
'带有该工作表副本的工作簿
活动表，收到
使用ActiveWorkbook
'另存为上面指定的文件名
.SaveAs文件名：=fn，文件格式：=xlOpenXMLWorkbookMacroEnabled
“只有一个工作表
附.工作表（1）
'可选地更改新工作表名称
.Name=“诸如此类”
'删除不需要的列
.Range（“A:G，K:L，O:XFD”）.entireclumn.Delete
'通过行向后循环拆分列N
对于i=.Cells（.Rows.Count，“E”）.End（xlUp）。行到1步骤-1
'重置p
p=mxt
'将列N分配给str
str=.Cells（即“E”）值
'在小于72个字符的空格上拆分列N的片段
p

感谢您的建议和建议。请检查我刚才添加的图片。