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个工作表，所以我认为代码应遍历所有工作表，查看每个单元格的第一个字符，然后将其放在另一个主工作表的特定列中。 / p>

不幸的是，我刚刚开始使用VBA，虽然我让剪贴板工作，但我对宏没有太多运气。

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

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

你可能想要这个，就像使用Pure 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

它得到了这个：

enter image description here

用于清理报废数据的VBA宏无法正常工作

1 个答案: