excel - 在新工作簿中动态匹配和复制/粘贴

Question

我需要从多个工作簿中提取数据：首先在每个工作簿中，我有 3 列（在我的示例中：Alpha、Bravo、Charlie）具有相同的标题但并不总是以相同的顺序.. 在它们下面我要复制的数据除了空单元格。每一列都需要在新工作簿的第一行中相互粘贴，中间有其他单元格（固定文本）。为了增加复杂性，Alpha 需要粘贴两次并附加前缀，而 Charlie 中的数据只需要每个单元格中的前 14 个字符。为此，新工作簿将保存在 txt 中，以双倍空格作为分隔符“”

现在我缺乏VBA知识，所以我有错误，而且很乱，我不知道如何复制前14个字符，它根本不起作用。我在手机上写了宏，它没有表格...

   sub transfert()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Workbooks.Add
ActiveWorkbook.SaveAs _
Filename:="C:\users\user\desktop\transfert.txt"
FileFormat:=xlText

dim wb_a as workbook
dim wb_b as workbook
dim ws_a as worksheet
dim wd_b as worksheet
Dim cl1 as long
Dim cl2 as long
Dim cl3  as long
Dim lr1 as long
Dim lr2 as long
Dim lr3 as long
dim d1 as long

Set wb_a = Workbooks("original.xlsm")
Set wb_b = Workbooks("transfert.txt")
Set ws_a = wb_a.Worksheets("from")
Set ws_b = wb_b.Worksheets("Sheet1")

[A1].Value = "FirstText"

with ws_a
if not IsError (application.match("Alpha", .Rows(1), 0)) Then
cl1 = Application.Match("Alpha", .Rows(1), 0)
lr1 = ws_a.cells(Rows.count, "cl1").End(xlUp).Row
.Range(cells(2, "cl1"), Cells("lr1", "cl1")).Copy
Else
MsgBow "Error Alpha"
end if
end with

ws_b.range("b1").PasteSpecial Paste:=xpastevalues, skipblank:=True, Transpose:=True

With Selection
For Each d1 In Selection
r.Value = 123
Next
End with

ws_b.cells(1, Columns.Count).End(xlToLeft).PasteSpecial paste:=xpastevalues, skipblank:=true, transpose:=True
ws_b.cells(1, Columns.Count).End(xlToLeft).Value = "SecondText"

with ws_a
if not IsError (application.match("Bravo", .Rows(1), 0)) Then
cl2 = Application.Match("Bravo", .Rows(1), 0)
lr2 = ws_a.cells(Rows.count, "cl2").End(xlUp).Row
.Range(cells(2, "cl2"), Cells("lr2", "cl2")).Copy
Else
MsgBow "Error Bravo"
end if
end with

ws_b.cells(1, Columns.Count).End(xlToLeft).PasteSpecial paste:=xpastevalues, skipblank:=true, transpose:=True
ws_b.cells(1, Columns.Count).End(xlToLeft).Value = "ThirdText"

with ws_a
if not IsError (application.match("Charlie", .Rows(1), 0)) Then
cl3 = Application.Match("Charlie", .Rows(1), 0)
lr3 = ws_a.cells(Rows.count, "cl3").End(xlUp).Row
.Range(cells(2, "cl3"), Cells("lr3", "cl3")).Copy
Else
MsgBow "Error Charlie"
end if
end with

ws_b.cells(1, Columns.Count).End(xlToLeft).PasteSpecial paste:=xpastevalues, skipblank:=true, transpose:=True
ws_b.cells(1, Columns.Count).End(xlToLeft).Value = "FourthText"

with ws_b.application
.decimalSeparator = "  "
.ThousandsSeparator = "  "
.UseSystemSeparator = False
End with

wb_b.Close SaveChange:=True
MsgBox "Done"

Application.cutcopymode = false
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

标签： excelvba