Перекрывающееся содержимое при импорте данных

Question

Я делаю проект с использованием Excel VBA, но у меня есть проблема при импорте данных. Каждый раз, когда я импортирую данные, они перекрывают существующий столбец.

Может ли кто-нибудь помочь мне решить эту проблему, ниже приведен код.

Private Sub CommandButton1_Click()

Dim myFile As String, text As String, textline As String, Name As Integer, Phone As Integer, Address1 As Integer, Dated As Integer
Dim Email As Integer, Postcode As Integer, SR As Integer, MTM As Integer, Serial As Integer, Problem As Integer, Action As Integer


myFile = "C:\Users\test.txt"


Open myFile For Input As #1
    Do Until EOF(1)
        Line Input #1, textline
        text = text & textline
    Loop
Close #1

Name = InStr(text, "Name")
Phone = InStr(text, "Phone")
Address1 = InStr(text, "Address1")
Email = InStr(text, "Email")
Postcode = InStr(text, "Postcode")
SR = InStr(text, "SR")
MTM = InStr(text, "MTM")
Serial = InStr(text, "Serial")
Problem = InStr(text, "Problem")
Action = InStr(text, "Action")
Dated = InStr(text, "Dated")


Range("C11").Value = Mid(text, Name + 6, 15)
Range("H13").Value = Mid(text, Phone + 6, 8)
Range("C15").Value = Mid(text, Address1 + 9, 25)
Range("C13").Value = Mid(text, Email + 6, 15)
Range("H16").Value = Mid(text, Postcode + 9, 5)
Range("C10").Value = Mid(text, SR + 4, 8)
Range("H14").Value = Mid(text, MTM + 5, 8)
Range("H15").Value = Mid(text, Serial + 8, 9)
Range("C17").Value = Mid(text, Problem + 9, 15)
Range("C18").Value = Mid(text, Action + 7, 10)
Range("H10").Value = Mid(text, Dated + 7, 10)

End Sub

Найти данные в прилагаемом листе. Телефон переходит к названию столбца, так же, как и к другим столбцам.Данные в H13 поступают в C11 также и другие.

---

,

редактировать

---

Привет, Пол, у меня все еще проблемы с печатью и преобразованием листа в PDF.

Без использования вашего первого или второго кода .. Я могу запустить приведенные ниже коды и перейти к листу в PDF, но теперь, когда после запуска первого и второго кода ur, приведенные ниже коды не могут преобразовать лист в PDF ...Я получаю сообщение «Ошибка приложения или объекта» и Ошибка выполнения 1004 «Документ не сохранен. Возможно, документ открыт или при сохранении произошла ошибка.

Могу ли я узнать, что не так с моим кодом?

Private Sub CommandButton2_Click()
    Dim FilePath As String
    Dim FileName As String
    Dim MyDate As String
    Dim report As String
    Dim Name As String

    FilePath = "C:\Users\Documents\test\"
    MyDate = Format(Date, " - MM-DD-YYYY")
    report = " - Quatation"
    Name = Worksheets("Sheet1").Range("C10")

    Sheets("Sheet1").Range("A1:I60").ExportAsFixedFormat Type:=xlTypePDF, _
        FileName:=FilePath & Name & MyDate & report
End Sub

---

Private Sub report()
    Dim myFile As String, lastRow As Long
    myFile = "C:\Users\Documents\test\" & Sheets("Sheet1").Range("C11") & "_" & Sheets("Sheet1").Range("C17") & Format(Now(), "yyyy-mm-dd") & ".pdf"
    lastRow = Sheets("Sheet3").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
    'Transfer data to sheet3
    Sheets("Sheet3").Cells(lastRow, 1) = Sheets("Sheet1").Range("C11")
    Sheets("Sheet3").Cells(lastRow, 2) = Sheets("Sheet1").Range("C17")
    Sheets("Sheet3").Cells(lastRow, 3) = Sheets("sheet1").Range("I28")
    Sheets("Sheet3").Cells(lastRow, 4) = Now
    Sheets("Sheet3").Hyperlinks.Add Anchor:=Sheets("Sheet3").Cells(lastRow, 5), Address:=myFile, TextToDisplay:=myFile
    'Create invoice in PDF format
    Sheets("sheet1").ExportAsFixedFormat Type:=xlTypePDF, FileName:=myFile
    Application.DisplayAlerts = False
    'create invoice in XLSX format
    ActiveWorkbook.SaveAs "C:\Users\Documents\test\" & Sheets("Sheet1").Range("C11") & "_" & Sheets("Sheet1").Range("C17") & "_" & Format(Now(), "yyyy-mm-dd") & ".xlsx", FileFormat:=51
    'ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub

---

Answer 1

Вы могли бы сделать код более эффективным, обслуживаемым и немного более динамичным

Две версии ниже определяют размер данных в зависимости от местоположения следующего токена ("Phone").
относительно текущего токена ("Name")

---

,

Версия 1 использует массивы для сопоставления токенов с различными ячейками на Sheet5

Option Explicit

Private Sub CommandButton1_Click()

    Const FULL_PATH = "C:\Users\test1.txt"

    Const TOKENS = "Name Phone Address1 Email Postcode SR MTM Serial Problem Action Dated"
    Const LOCATIONS = "C11 H13 C15 C13 H16 C10 H14 H15 C17 C18 H10"

    Dim fId As String, txt As String, txtLen As Long, idArr As Variant, locArr As Variant

    fId = FreeFile
    Open FULL_PATH For Input As fId
        txt = Input(LOF(fId), fId)  'Read entire file (not line-by-line)
    Close fId
    txtLen = Len(txt)

    idArr = Split(TOKENS)
    locArr = Split(LOCATIONS)

    Dim i As Long, k As String, sz As Long, found As Long, ub As Long

    ub = UBound(idArr)

    With ThisWorkbook.Worksheets("Sheet5")     '<--- Update sheet name
        For i = LBound(idArr) To ub
            k = idArr(i)        'Name, Phone, etc
            found = InStr(txt, k) + Len(k) + 1  'Find current key in file
            If found > 0 Then   'Determine item length by finding the next key
                If i < ub Then sz = InStr(txt, idArr(i + 1)) Else sz = txtLen + 2
                .Range(locArr(i)).Value2 = Trim$(Mid$(txt, found, sz - found - 1))
            End If
        Next
    End With
End Sub

---

,

Версия 2 использует словарь

Private Sub CommandButton1_Click()
    Const FULL_PATH = "C:\Users\test2.txt"
    Dim fId As String, txt As String, txtLen As Long, d As Object, dc As Long

    fId = FreeFile
    Open FULL_PATH For Input As fId
        txt = Input(LOF(fId), fId)  'Read entire file (not line-by-line)
    Close fId
    txtLen = Len(txt)
    Set d = CreateObject("Scripting.Dictionary")
    d("Name") = "C11"   'Same as: d.Add Key:="Name", Item:="C11"
    d("Phone") = "H13"
    d("Address1") = "C15"
    d("Email") = "C13"
    d("Postcode") = "H16"
    d("SR") = "C10"
    d("MTM") = "H14"
    d("Serial") = "H15"
    d("Problem") = "C17"
    d("Action") = "C18"
    d("Dated") = "H10"
    dc = d.Count

    Dim i As Long, k As String, sz As Long, found As Long
    With ThisWorkbook.Worksheets("Sheet5")     '<--- Update sheet name
        For i = 0 To dc - 1     'd.Keys()(i) is a 0-based array
            k = d.Keys()(i)     'Name, Phone, etc
            found = InStr(txt, k) + Len(k) + 1  'Find the (first) key in file
            If found > 0 Then   'Determine item length by finding the next key
                If i < dc - 1 Then sz = InStr(txt, d.Keys()(i + 1)) Else sz = txtLen + 2
                .Range(d(k)).Value2 = Trim$(Mid$(txt, found, sz - found - 1))
            End If
        Next
    End With
End Sub

---

,

test1.txt

Name Name1
Phone Phone1
Address1 Address11
Email Email1
Postcode Postcode1
SR SR1
MTM MTM1
Serial Serial1
Problem Problem1
Action Action1
Dated Dated1

Результат 1:

,

test2.txt

Name Name2 Phone Phone2 Address1 Address12 Email Email2 Postcode Postcode2 SR SR2 MTM MTM2 Serial Serial2 Problem Problem2 Action Action2 Dated Dated2

Результат 2:

---