数据转换

ly284257

以前在论坛求助大神，写了段代码，可以把B列转换成A列数据。
但是这个代码有部分是错误的（标黄色部分），苦思冥想好久都无法解决，特来求助论坛大佬，看代码要怎么优化。

原代码：

Option Explicit

Sub 同望代码转换()

Dim i, j, a
Dim tstr$
Dim arr, brr
j = Range("B65536").End(xlUp).Row '判定总有多少数据
Range("A1：A" & j).ClearContents
arr = [b1].CurrentRegion.Resize(, 2)
For i = 1 To UBound(arr)
   If Left(arr(i, 1), 1) <> "-" Then tstr = arr(i, 1)
         If arr(i, 1) = tstr Then
         arr(i, 2) = arr(i, 1)
         Else: arr(i, 2) = tstr & arr(i, 1)
         End If
  
Next
[a1].Resize(UBound(arr)) = Application.Index(arr, 0, 2)

With ActiveSheet.UsedRange
  .NumberFormatLocal = "G/通用格式"
  .Value = .Value
End With
End Sub

ly284257

麻烦有空的大佬帮忙看看

selen

Sub 同望代码转换2()
Dim i, iRow
Dim 一级, 二级
Dim arr, brr
iRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row - 1
arr = Sheet1.Range("B2").Resize(iRow)
ReDim brr(1 To iRow, 1 To 1)
Range("A2").Resize(iRow).ClearContents
For i = 1 To UBound(arr)
    If Left(arr(i, 1), 1) <> "-" Then
        一级 = arr(i, 1)
        brr(i, 1) = 一级
    Else
        If Val(arr(i, 1)) = 0 Then
            二级 = 一级 & arr(i, 1)
            brr(i, 1) = 二级
        Else
            brr(i, 1) = 二级 & arr(i, 1)
        End If
    End If
Next
Sheet1.Range("A2").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

selen

1. Sub 同望代码转换2()
   
2. Dim i, iRow
   
3. Dim 一级, 二级
   
4. Dim arr, brr
   
5. iRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row - 1
   
6. arr = Sheet1.Range("B2").Resize(iRow)
   
7. ReDim brr(1 To iRow, 1 To 1)
   
8. Range("A2").Resize(iRow).ClearContents
   
9. For i = 1 To UBound(arr)
   
10.     If Left(arr(i, 1), 1) <> "-" Then
    
11.         一级 = arr(i, 1)
    
12.         brr(i, 1) = 一级
    
13.     Else
    
14.         If Val(arr(i, 1)) = 0 Then
    
15.             二级 = 一级 & arr(i, 1)
    
16.             brr(i, 1) = 二级
    
17.         Else
    
18.             brr(i, 1) = 二级 & arr(i, 1)
    
19.         End If
    
20.     End If
    
21. Next
    
22. Sheet1.Range("A2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
23. End Sub
    

复制代码

用这段代码

selen

写好了 但是发不出去

selen

1. Sub 同望代码转换2()
   
2. Dim i, iRow
   
3. Dim 一级, 二级
   
4. Dim arr, brr
   
5. iRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row - 1
   
6. arr = Sheet1.Range("B2").Resize(iRow)
   
7. ReDim brr(1 To iRow, 1 To 1)
   
8. Range("A2").Resize(iRow).ClearContents
   
9. For i = 1 To UBound(arr)
   
10.     If Left(arr(i, 1), 1) <> "-" Then
    
11.         一级 = arr(i, 1)
    
12.         brr(i, 1) = 一级
    
13.     Else
    
14.         If Val(arr(i, 1)) = 0 Then
    
15.             二级 = 一级 & arr(i, 1)
    
16.             brr(i, 1) = 二级
    
17.         Else
    
18.             brr(i, 1) = 二级 & arr(i, 1)
    
19.         End If
    
20.     End If
    
21. Next
    
22. Sheet1.Range("A2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
23. End Sub
    

复制代码

selen

Sub 同望代码转换2()
Dim i, iRow
Dim 一级, 二级
Dim arr, brr
iRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row - 1
arr = Sheet1.Range("B2").Resize(iRow)
ReDim brr(1 To iRow, 1 To 1)
Range("A2").Resize(iRow).ClearContents
For i = 1 To UBound(arr)
    If Left(arr(i, 1), 1) <> "-" Then
        一级 = arr(i, 1)
        brr(i, 1) = 一级
    Else
        If Val(arr(i, 1)) = 0 Then
            二级 = 一级 & arr(i, 1)
            brr(i, 1) = 二级
        Else
            brr(i, 1) = 二级 & arr(i, 1)
        End If
    End If
Next
Sheet1.Range("A2").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

xiaocake

正确答案 207-1-f-1 下面两个数据，正确应该是207-1-f-2   207-1-f-3吧，如果不是，我找不出来规律。。。

selen

Sub 同望代码转换2()
Dim i, iRow
Dim 一级, 二级
Dim arr, brr
iRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row - 1
arr = Sheet1.Range("B2").Resize(iRow)
ReDim brr(1 To iRow, 1 To 1)
Range("A2").Resize(iRow).ClearContents
For i = 1 To UBound(arr)
    If Left(arr(i, 1), 1) <> "-" Then
        一级 = arr(i, 1)
        brr(i, 1) = 一级
    Else
        If Val(arr(i, 1)) = 0 Then
            二级 = 一级 & arr(i, 1)
            brr(i, 1) = 二级
        Else
            brr(i, 1) = 二级 & arr(i, 1)
        End If
    End If
Next
Sheet1.Range("A2").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

ly284257

xiaocake 发表于 2023-2-28 17:25
正确答案 207-1-f-1 下面两个数据，正确应该是207-1-f-2   207-1-f-3吧，如果不是，我找不出来规律。。。

确实，那里是我疏忽了