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

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

0 个答案: