Динамическое сопоставление и копирование / вставка в новую книгу

Question

Мне нужно извлечь данные из нескольких рабочих книг: сначала в каждой рабочей книге у меня есть 3 столбца (в моем примере: Альфа, Браво, Чарли) с одинаковыми заголовками, но не всегда в том же порядке. Под ними - данные, которые я хочускопировать кроме пустых ячеек. Каждый столбец необходимо вставлять после первой строки в новую строку в новой рабочей книге с дополнительными ячейками (фиксированный текст) между ними. Чтобы добавить сложности, Альфа должна быть вставлена ​​дважды с дополнительным префиксом, а данные в Чарли нужны только первые 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