Forum Discussion

Bixente's avatar
Bixente
Copper Contributor
Aug 11, 2021
Solved

Excel Makros code seems right but doesn't work as expected

Hello I'd love to get  some Data from a few sheets, listed on a single sheet. I wrote this code: Sub Tabelle_zusammanfassen() Dim i As Integer Dim Zusammenfassung As Worksheet Set Zusamm...
excel
Macros and VBA
  • Subodh_Tiwari_sktneer's avatar
    Subodh_Tiwari_sktneer
    Aug 14, 2021

    Bixente 

    Please try this...

    Sub CopyDataToMasterSheet()
Dim wsSummary       As Worksheet
Dim ws              As Worksheet
Dim dlr             As Long
Dim RngTotal        As Range
Dim r               As Long

Application.ScreenUpdating = False

Set wsSummary = Worksheets("Summary")

For Each ws In ThisWorkbook.Worksheets
    If Not ws Is wsSummary Then
        Set RngTotal = ws.Columns(1).Find(what:="Total", lookat:=xlPart)
        If Not RngTotal Is Nothing Then
            r = RngTotal.End(xlUp).Row
            If wsSummary.Range("H1").Value = "" Then
                dlr = 1
            Else
                dlr = wsSummary.Cells(Rows.Count, "H").End(xlUp).Row + 1
            End If
            ws.Range("A" & r).Copy wsSummary.Range("H" & dlr)
            ws.Range("J" & r).Copy wsSummary.Range("I" & dlr)
            ws.Range("Q" & RngTotal.Row).Copy wsSummary.Range("J" & dlr)
        End If
    End If
Next ws
Application.ScreenUpdating = True
End Sub

     

    In the attached, you may click the button called "Copy Data" on Summary Sheet to run the code.

     

     

Subodh_Tiwari_sktneer's avatar
Subodh_Tiwari_sktneer
Silver Contributor
Aug 11, 2021

Bixente 

 

Try it like this...

Sub Tabelle_zusammanfassen()
Dim i               As Integer
Dim Summary         As Worksheet
Dim RangeTargetTab  As Range
Dim LastLineSummary As Long

Set Summary = Worksheets("Summary")
For i = 2 To Worksheets.Count

Set RangeTargetTab = Worksheets(i).Range("b5")
LastLineSummary = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
RangeTargetTab.Copy Summary.Range("A" & LastLineSummary)
Next i

End Sub

 

Or you may try it like this...

Sub Tabelle_zusammanfassen()
Dim Summary         As Worksheet
Dim ws              As Worksheet
Dim RangeTargetTab  As Range
Dim i               As Integer
Dim dlr             As Long

Application.ScreenUpdating = False

Set Summary = Worksheets("Summary")

For Each ws In ThisWorkbook.Worksheets
    If Not ws Is Summary Then
        dlr = Summary.Cells(Rows.Count, "A").End(xlUp).Row + 1
        ws.Range("B5").Copy Summary.Range("A" & dlr)
    End If
Next ws

Application.ScreenUpdating = True
End Sub

 

 

 

Bixente's avatar
Bixente
Copper Contributor
Aug 12, 2021

Subodh_Tiwari_sktneer Thank you so much. This is working. You're already a hero to me.

 

I still would have a question: For the next column i don't need the data from the same cell in every sheet but always from the last line of a table. But it isn't always the last line from the sheet. The table always starts at the line 8. Let's say i have a table with 5 lines and i need the data from the last one in column A. Ist this possible somehow?


Best wishes
Bixente

  • Subodh_Tiwari_sktneer's avatar
    Subodh_Tiwari_sktneer
    Silver Contributor
    Aug 12, 2021

    Bixente 

    You're welcome! Yes, it seems possible but to discard any confusion, I suggest you to upload a sample file along with some dummy data on data sheets and expected output on Summary Sheet to let me know what exactly you are trying to achieve. Add some comments on the Summary Sheet to describe the logic behind the output if necessary.

      • Subodh_Tiwari_sktneer's avatar
        Subodh_Tiwari_sktneer
        Silver Contributor
        Aug 12, 2021

        Bixente 

         

        Does the following code work for you?

        Sub Tabelle_zusammanfassen()
Dim Summary         As Worksheet
Dim ws              As Worksheet
Dim RangeTargetTab  As Range
Dim i               As Integer
Dim dlr             As Long
Dim n               As Variant

Application.ScreenUpdating = False

Set Summary = Worksheets("Summary")

For Each ws In ThisWorkbook.Worksheets
    If Not ws Is Summary Then
        dlr = Summary.Cells(Rows.Count, "E").End(xlUp).Row + 1
        n = Application.Match(1, ws.Columns(1), 0)
        If Not IsError(n) Then
            ws.Range("A" & n).Copy Summary.Range("E" & dlr)
            ws.Range("D" & n).Copy Summary.Range("F" & dlr)
        End If
    End If
Next ws

Application.ScreenUpdating = True
End Sub

Resources