VBA宏清理刮掉的数据不起作用

Question

我从网上抓取了大量数据和未格式化的数据。我现在正在尝试纠正一些 vba 以将这些东西转换为可用数据。

原始数据在excel中的结构如下：

1. Centre hospitalier René Dubos (Pontoise)


Capacité totale : 1048 places
Type de structure : CH (Centre Hospitalier)
Dépend de : Centre Hospitalier René Dubos (Pontoise)
Centre hospitalier René Dubos
Adresse : 6, avenue de L'Ile de France 95303 Pontoise

2. Groupement hospitalier Eaubonne - Montmorency - Hôpital Simone Veil (MONTMO...  B


Capacité totale : 916 places
Type de structure : CH (Centre Hospitalier)
Dépend de : Groupement hospitalier Eaubonne - Montmorency (Hôpital Simone Veil) (MONTMORENCY)
Groupement hospitalier Eaubonne - Montmorency - Hôpital Simone Veil
Adresse : 1, rue Jean Moulin 95160 MONTMORENCY

3. Centre Hospitalier de Gonesse (Gonesse)  C


Capacité totale : 878 places
Type de structure : CH (Centre Hospitalier)
Dépend de : Centre Hospitalier de Gonesse (Gonesse)
Centre Hospitalier de Gonesse 
Adresse : 25 rue Bernard Février 95503 Gonesse

等等……

我正在尝试执行以下操作：

如果单元格以数字开头，那么这应该放在另一个工作表中表格的第一列中。 然后，我想在单独的列中输入与“capacite totale”、“type de structure”、“depend de”和“address”相对应的每一行，但在我们复制以数字开头的单元格的同一行上（即 1.）。

一个工作簿中有大约 300 个工作表，所以我认为代码应该遍历所有工作表，查看每个单元格的第一个字符，然后将其放在另一个主工作表的特定列中。

不幸的是，我刚开始使用 VBA，虽然我得到了 scraper 的工作，但我对宏的运气并不好。

到目前为止，这是我的代码：

Sub cleaning_data()

' Declare Current as a worksheet object variable.
 Dim Current As Worksheet

 ' Loop through all of the worksheets in the active workbook.
 For Each Current In Worksheets

    For x = 1 To 150
        If IsEmpty(Cells(x, 1)) Then
            x = x + 1
        Else
            x = x + 1
        End If
        
        'Is it a title
        If IsNumeric(Left(Cells(x, 1), 1)) Then
            ' Copy cell and put it as first entry in table
            Cells(x, 1).Copy
            Sheets("Sheet1").Cells(x, 1).Select
            Sheets("Sheet1").Cells(x, 1).Paste
            x = x + 1
        
         'Is it capacity
         ElseIf Left(Cells(x, 1), 2) = "Ca" Then
             Cells(x, 1).Copy
             'paste in column 2
             Sheets("Sheet1").Cells(x, 2).Paste
             x = x + 1
             
        'Is it type
         ElseIf Left(Cells(x, 1), 2) = "Ty" Then
             Cells(x, 1).Copy
             'paste where column 3
             Sheets("Sheet1").Cells(x, 3).Paste
             x = x + 1
             
         'Is it what it depends of
         ElseIf Left(Cells(x, 1), 2) = "Dé" Then
             Cells(x, 1).Copy
             Sheets("Sheet1").Cells(x, 4).Paste
             'paste where appropriate
             x = x + 1
            
             
         'Is it the address
         ElseIf Left(Cells(x, 1), 2) = "Ad" Then
             Cells(x, 1).Copy
             'paste where appropriate
             Sheets("Sheet1").Cells(x, 5).Paste
             x = x + 1
        End If
    Next x
    Next
        
End Sub

有人对我如何修复此代码有想法吗？

谢谢！

Answer 1

你可能想要这个，比如使用纯 VBA 的转置：

Sub sof20327437CleanData()

  Dim i As Long, iRow As Long, iCol As Long
  Dim x
  Dim strLine
  ' Declare wksDest as a worksheet object variable.
  Dim wksDest As Worksheet
  ' Declare wksCurrent as a worksheet object variable.
  Dim wksCurrent As Worksheet

  '
  iRow = 1
  Set wksDest = Sheets("Sheet1")
  wksDest.UsedRange.Clear
 '
  wksDest.Cells(1, 1) = "No."
  wksDest.Cells(1, 2) = "Capacité totale"
  wksDest.Cells(1, 3) = "Type de structure"
  wksDest.Cells(1, 4) = "Dépend de"
  wksDest.Cells(1, 5) = "Adresse"


  ' Loop through all of the worksheets in the active workbook.
  For Each wksCurrent In Worksheets

    iCol = 0
    'Set wksCurrent = ActiveSheet

    For x = 1 To 150

      ' by strLine to gain CPU, a small RAM instead to each time accessing the Cell:
      '
      strLine = Trim(wksCurrent.Cells(x, 1))

      ' skip empty line:
      If (Not IsEmpty(strLine)) Then

        'Is it a title
        If IsNumeric(Left(strLine, 1)) Then
          iCol = 1
          iRow = iRow + 1

        'Is it capacity
        ElseIf (InStr(1, strLine, "Capacit", vbTextCompare) = 1) Then
          iCol = 2

        'Is it type
        ElseIf (InStr(1, strLine, "Type", vbTextCompare) = 1) Then
          iCol = 3

        'Is it what it depends of
        ElseIf (InStr(1, strLine, "Dépend", vbTextCompare) = 1) Then
          iCol = 4

        'Is it the address
        ElseIf (InStr(1, strLine, "Adresse", vbTextCompare) = 1) Then
          iCol = 5
        End If

        If (iCol > 0) Then
          If (iCol >= 2) Then
            ' cut useless info like Adresse :
            i = InStr(1, strLine, ":", vbTextCompare)
            If (i > 0) Then
              strLine = Mid(strLine, i + 2)
            End If
          End If
          ' we concat string, as Dépende can have some lines:
          If (Not IsEmpty(wksDest.Cells(iRow, iCol))) Then
            strLine = " " & strLine
          End If
          wksDest.Cells(iRow, iCol) = wksDest.Cells(iRow, iCol) & strLine
        End If

      End If
    Next
    '
    'Exit For
    '
  Next
'
  Set wksDest = Nothing
  Set wksCurrent = Nothing
'
End Sub

得到这个：