Thread: Copy Varying Range Sizes from Multiple Sheets to Main Sheet

Hi Guru's

I have couple of issues and questions with this Macro.

1.) Is there a way to change the reference point (starting point) when it copies the information from each sheet. I am having problems because it starts at "A1" on each sheet and really need it to start at "B1"

2.) Data (row) fails to copy if I have missing data in column A even though I might have data in consecutive columns. Is there a way to make the count rows function look at cells A:F?

I have attached a file, that will probably explain better my situation and it contains the macro in quesiton.

Any help would be much appreciated.

-Wesley

Hello,

I reprogrammed your code.*Try my version.

Code:

Sub test_pmo()
Dim SUMMA As Worksheet
Dim S As Worksheet
Dim C As Range
Dim R As Range
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim Lig&
Dim var
Dim T()
Dim myProduct
Dim Couleurs
Couleurs = Array(34, 35, 36, 40)
Set SUMMA = Sheets("Summary")
For Each myProduct In Array("Fruit", "Vegetables", "Breads", "Meat")
  For Each S In ActiveWorkbook.Worksheets
    If Not S Is SUMMA And S.Name <> "Exposé" Then
      Set C = S.Range("A:F").Find(myProduct, LookIn:=xlValues)
      If Not C Is Nothing Then
        Set R = C.CurrentRegion
        If S.Name <> "Template" Then Set R = R.Resize(R.Rows.Count - (C.Row - R.Row + 2)).Offset(C.Row - R.Row + 2, 0)
        var = R
        cpt& = 0
        Erase T
        For i& = 1 To UBound(var, 1)
          If var(i&, 1) <> "" Then
            cpt& = cpt& + 1
            ReDim Preserve T(1 To 3, 1 To cpt&)
            For j& = 1 To 3
              T(j&, cpt&) = var(i&, j&)
            Next j&
          End If
        Next i&
        Lig& = SUMMA.[a65536].End(xlUp).Row + 1
        Set R = SUMMA.Range(SUMMA.Cells(Lig&, 1), SUMMA.Cells(UBound(T, 2) + Lig& - 1, UBound(T, 1)))
        R = Application.WorksheetFunction.Transpose(T)
        If S.Name = "Template" Then
          R.Interior.ColorIndex = Couleurs(k&)
          Set R = SUMMA.Range("a" & Lig& & ":c" & Lig& & "")
          R.Font.Bold = True
          BordersRange R
          Set R = R.Offset(1, 0)
          R.HorizontalAlignment = xlCenter
          BordersRange R, True
        Else
          BordersRange R, True
          Set R = R.Resize(R.Rows.Count, R.Columns.Count - 2).Offset(0, 1)
          R.NumberFormat = "$# ##0.00"
          R.HorizontalAlignment = xlCenter
          R.Offset(0, 1).HorizontalAlignment = xlCenter
        End If
      End If
    End If
  Next S
  k& = k& + 1
Next myProduct
End Sub

Sub BordersRange(R As Range, Optional Inside As Boolean)
Dim Fin&
Dim i&
Fin& = 10
If Inside Then Fin& = 12
On Error Resume Next
For i& = 7 To Fin&
  R.Borders(i&).LineStyle = xlContinuous
Next i&
End Sub

Best regards.

PMO
Patrick Morange