Question

'Text to columns, seperate into columns
wsx1.Columns(2).TextToColumns , _
Destination:=wsx1.Range("B1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Other:=True, _
OtherChar:="|", _
TrailingMinusNumbers:=False
'remove unwanted information & shift cells accross
For Each cell In wsx1.Range("A1:AD50000")
    If cell.Value = "Pre-trigger Time: 20[s]" Then
        cell.Delete Shift:=xlShiftToLeft
    End If
 Next cell
 
 For Each cell In wsx1.Range("A1:AD50000")
    If cell.Value = "§@" Then
        cell.Delete Shift:=xlShiftToLeft
    End If
 Next cell
'Now, copy what you want from x:
lRows = wsx1.Cells(wsx1.Rows.Count, "A").End(xlUp).Row
lCols = wsx1.Cells(1, wsx1.Columns.Count).End(xlToRight).Column
Set rng3 = wsx1.Range(wsx1.Cells(1, 1), wsx1.Cells(lRows, lCols))
'Identify next empty range in final sheet
sizex = rng3.Columns.Count
sizey = rng3.Rows.Count
lRows2 = wsy1.Cells(wsy1.Rows.Count, "A").End(xlUp).Row
DRows = sizey + lRows2
DCols = sizex
Set rng4 = wsy1.Range(wsy1.Cells(lRows2 + 1, 1), wsy1.Cells(DRows, DCols))
rng4.Value = rng3.Value
wsy1.Columns("A:Q").AutoFit
'Close x:
Application.DisplayAlerts = False
x.Close
Application.DisplayAlerts = True

我正在从CSV文件中提取信息，首先，我使用文本将列分隔为列，然后将数据传输到正确的工作簿。我遇到的问题是试图找到一种识别文本内容的方法，例如日期应该在第2栏，时间在第3栏，等等......

Samatar1 Date:01/01/15 Time: 12:46 Record Duration: 25 s Data: exc Experiment: S2 Workspace : mina 

The above format is how the text is shown in the table

Answer 1

Sub move_Data()
Dim iL As Long, rng1 As Range, rng2 As Range, pasterng As Range, lRow As Long, lRows As Long, str As String, var As Range, var1 As Range, var2 As Range, var3 As Range, var4 As Range, var5 As Range, var6 As Range, titlerow As Long

Set ws1 = Sheet1
Set ws2 = Sheet2

iL = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row

For i = 1 To iL

Set Title1 = ws1.Cells(i, 1)

titlerow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
titlerows = titlerow + 1

Set Title2 = ws2.Cells(titlerows, 1)

Title2.Value = Title1.Value

Set rng1 = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, ws1.Columns.Count).End(xlToLeft).Columns)
Set var = rng1.Find("Date: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 2)
pasterng.Value = var.Value
End If

Set var1 = rng1.Find("Time: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var1 Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 3).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 3)
pasterng.Value = var1.Value
End If

Set var2 = rng1.Find("Recording Duration: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var2 Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 4).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 4)
pasterng.Value = var2.Value
End If

Set var3 = rng1.Find("Database: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var3 Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 5).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 5)
pasterng.Value = var3.Value
End If

Set var4 = rng1.Find("Experiment: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var4 Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 6).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 6)
pasterng.Value = var4.Value
End If

Set var5 = rng1.Find("Workspace: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var5 Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 7).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 7)
pasterng.Value = var5.Value
End If

Set var6 = rng1.Find("Devices: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var6 Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 8).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 8)
pasterng.Value = var6.Value
End If

Set var7 = rng1.Find("Program Description: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var7 Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 9).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 9)
pasterng.Value = var7.Value
End If

Set var8 = rng1.Find("WP: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var8 Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 10).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 10)
pasterng.Value = var8.Value
End If

Set var9 = rng1.Find("RP: ", LookIn:=xlValues, LookAt:=xlPart)
If Not var9 Is Nothing Then
lRow = ws2.Cells(ws2.Rows.Count, 11).End(xlUp).Row
lRows = lRow + 1
Set pasterng = ws2.Cells(lRows, 11)
pasterng.Value = var9.Value
End If

Set Comments = var9.Offset(0, 1)

Set Commentrng = ws1.Range(Comments, ws1.Cells(i, ws1.Columns.Count).End(xlToLeft))
sizex = Commentrng.Columns.Count
sizexs = sizex + 11
Set Commentpaste = ws2.Range(ws2.Cells(titlerows, 12), ws2.Cells(titlerows, sizexs))
Commentpaste.Value = Commentrng.Value

Next i
End Sub

获取脚本以识别文本并根据单元格文本排列正确的列

1 个答案: