CODEWITHSUNDEEP
vbaloopsexcel
Jakub Mościcki
Jakub Mościcki

Reputation: 11

VBA checking range in different columns

i've got xls file with multiple sheets and multiple columns with data (in blocks of 6 columns) in them. I have to copy this data to the last sheet, each under the last one.

In other words, it now looks like this:

a b c d

a b c d

a b c d

and I'd like it to look like this in the last sheet:

a

a

a

b

b

b

c

c

c

d

d

d

I managed to create macro that is copying first 6 columns from each sheet but I can not make a loop which would move through columns in each sheet:

Sub kopiuj_wszystko()

Dim kolumna As Integer
For Each oWBK In ThisWorkbook.Worksheets
For j = 1 To 1000
If oWBK.Name <> "podsumowanie" Then
' Kopiuj

oWBK.Select

x = Range(j & "1000").End(xlUp).Row 'sprawdź ilość wypełnionych wierszy
y = 6 'ogranicz do kolumny F
oWBK.Cells(x, y).Select
Z = ActiveCell.Address
Range("A9", Z).Select
'Application.CutCopyMode = False
Selection.Copy

'Wklej
Sheets("podsumowanie").Select
E = Range("c10000").End(xlUp).Row
R = 3
Sheets("podsumowanie").Cells(E, R).Select

ActiveSheet.Paste

'Kopiuj kategorię
oWBK.Select
T = Range("A1").Value
Application.CutCopyMode = False
Selection.Copy

'Wklej kategorię
w = 1
Sheets("podsumowanie").Select
Sheets("podsumowanie").Cells(E, w).Select
L = ActiveCell.Address
Range(L).Value = T

'Kopiuj index
oWBK.Select
T = Range("C3").Value
Application.CutCopyMode = False
Selection.Copy

'Wklej index
w = 2
Sheets("podsumowanie").Select
Sheets("podsumowanie").Cells(E, w).Select
L = ActiveCell.Address
Range(L).Value = T

End If
Next j

Next oWBK

End Sub

Upvotes: 1

Views: 735

Answers (1)

Steve
Steve

Reputation: 1638

Very simple bit of code here which will work no matter how many columns there are: (Cycles through each cell (slow with larger amounts of data)

Sub ColumnsToOne()

Dim wsT As Worksheet: Set wsT = ThisWorkbook.Sheets("Sheet2")
Dim x As Long
Dim y As Long
Dim z As Long

z = 1
For Each wsF In ThisWorkbook.Sheets
x = 1
y = 1
If wsF.Name <> wsT.Name Then
    Do While Len(wsF.Cells(x, y)) <> 0
        Do While Len(wsF.Cells(x, y)) <> 0
            wsF.Cells(x, y).Copy wsT.Cells(z, 1): z = z + 1: x = x + 1
        Loop
        x = 1: y = y + 1
    Loop
End If
Next

End Sub

The below code copies each range and adds it to the sheet: (Faster with larget data sets)

Sub CopyColumnsToOne()
Dim wsT As Worksheet: Set wsT = ThisWorkbook.Sheets("Sheet2")
Dim y As Long
For Each wsF In ThisWorkbook.Sheets
    If wsF.Name <> wsT.Name Then
        For y = 1 To 6
            wsF.Range(wsF.Cells(1, y), wsF.Cells(wsF.Cells(wsF.Rows.Count, y).End(xlUp).Row, y)).Copy wsT.Cells(wsT.Range("A65536").End(xlUp).Row + 1, 1)
        Next
    End If
Next
End Sub

Upvotes: 1

Related Questions