Sub TableToTXT()
Dim rRg As Range
Dim sDist As String
Dim aTXT(), lCl&, l&: l = 1
With Worksheets(1)
For Each rRg In .UsedRange
If rRg.Row <> 1 And rRg.Column <> 1 And rRg.Value <> "" Then
Select Case rRg.Value
Case 0: sDist = "{length:5, color:#FF0000, weight:3}"
Case 1: sDist = " {length:10, color:#FF0000}"
Case 2: sDist = "{length:20, color:#FF9999}"
Case 3 To 1000: sDist = "{length:" & rRg.Value * 10 & "}"
End Select
ReDim Preserve aTXT(1 To 2, 1 To l)
aTXT(1, l) = rRg.Value
aTXT(2, l) = .Cells(rRg.Row, 1) & " -- " & .Cells(1, rRg.Column) & " " & sDist
l = l + 1
End If
Next
lCl = .Cells(1, Columns.Count).End(xlToLeft).Column: l = l - 1
.Range(Cells(1, lCl + 1), Cells(l, lCl + 2)) = Application.Transpose(aTXT)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Cells(1, lCl + 1), Order:=xlAscending
With .Sort
.SetRange Range(Cells(1, lCl + 1), Cells(l, lCl + 2))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ReDim aTXT(1 To 2, 1 To l)
aTXT = Application.Transpose(.Range(Cells(1, lCl + 1), Cells(l, lCl + 2)))
.Range(Cells(1, lCl + 1), Cells(l, lCl + 2)).ClearContents
For l = 1 To UBound(aTXT, 2)
Open "D:\\file.txt" For Append As #1
Print #1, aTXT(2, l)
Close #1
Next l
End With
End Sub
|
