PDA

View Full Version : [SOLVED] Dynamically Copy and Paste



bananas
06-12-2016, 02:38 AM
Hi all,
I’m new to VBA and need some help with copying dynamic ranges from Sheet1 to Sheet2, in Book2.
After many days of searching on internet and experimenting with code, I still can't get it to work.

I have eight dynamic ranges in six columns in sheet1 (48 ranges in total), to be copied to 48 static cells in sheet2.

Below you can read code I have used so far. This code works great for the first dynamic range (A6:I8), but I'm stuck when I shall start over at second dynamic range (A13:I24) in Col"A", and next occ. of "ABC", to next occ. of "DEF* (Col"A") or (empty cell in col."B","C","D","E" and "I"), and so on down to the eighth dynamic range (A106:I112).

I have attached Workbook "Book2" so it will be easier to understand the problem.




Option Explicit


Sub Module1()


Dim foundA As Range, _
foundB As Range
Dim newSht As Worksheet

Application.ScreenUpdating = False
On Error GoTo Terminate


With Sheets("Sheet1").Columns(1)
Set foundA = .Find("ABC")
Set foundB = .Find("DEF*", After:=foundA, SearchDirection:=xlNext)
End With
Range(foundA(2), foundB(0)).Copy
Set newSht = Sheets("Sheet2")
newSht.Range("A2").PasteSpecial

With Sheets("Sheet1").Columns(2)
Set foundA = .Find("GHI")
Set foundB = .Find("", After:=foundA, SearchDirection:=xlNext)
End With
Range(foundA(2), foundB(0)).Copy
Set newSht = Sheets("Sheet2")
newSht.Range("C2").PasteSpecial


With Sheets("Sheet1").Columns(3)
Set foundA = .Find("JKL")
Set foundB = .Find("", After:=foundA, SearchDirection:=xlNext)
End With
Range(foundA(2), foundB(0)).Copy
Set newSht = Sheets("Sheet2")
newSht.Range("F2").PasteSpecial




With Sheets("Sheet1").Columns(4)
Set foundA = .Find("MNO")
Set foundB = .Find("", After:=foundA, SearchDirection:=xlNext)
End With
Range(foundA(2), foundB(0)).Copy
Set newSht = Sheets("Sheet2")
newSht.Range("G2").PasteSpecial




With Sheets("Sheet1").Columns(5)
Set foundA = .Find("PQR")
Set foundB = .Find("", After:=foundA, SearchDirection:=xlNext)
End With
Range(foundA(2), foundB(0)).Copy
Set newSht = Sheets("Sheet2")
newSht.Range("I2").PasteSpecial




With Sheets("Sheet1").Columns(9)
Set foundA = .Find("YZ2")
Set foundB = .Find("", After:=foundA, SearchDirection:=xlNext)
End With
Range(foundA(2), foundB(0)).Copy
Set newSht = Sheets("Sheet2")
newSht.Range("R2").PasteSpecial




Exit Sub
Terminate:
MsgBox "Error in Code"
End


Application.ScreenUpdating = True
End Sub






Any help will be greatly appreciated.
Thanks!

mdmackillop
06-12-2016, 04:44 AM
Welcome to VBAX


Option Explicit


Sub CopyDynamic()
Dim ABC(), DEF()
Dim c As Range
Dim i As Long, j As Long
Dim FA As String


ReDim ABC(1000), DEF(1000)

With Sheets(1).Columns(1)
Set c = .Find("ABC", lookat:=xlWhole, after:=Cells(1, 1))
FA = c.Address
Do
ABC(i) = c.Offset(1).Address
i = i + 1
Set c = .FindNext(c)
Loop Until c Is Nothing Or c.Address = FA


i = 0
Set c = .Find("DEF", lookat:=xlPart, after:=Cells(1, 1))
FA = c.Address
Do
DEF(i) = c.Offset(-1).Address
i = i + 1
Set c = .FindNext(c)
Loop Until c Is Nothing Or c.Address = FA
End With

ReDim Preserve ABC(i - 1)
ReDim Preserve DEF(i - 1)


With Sheets(2)
For j = 0 To i - 1
Sheets(1).Range(ABC(j) & ":" & DEF(j)).Interior.ColorIndex = 7
Set c = Sheets(1).Range(ABC(j) & ":" & DEF(j))
c.Resize(, 9).Copy .Cells(2, 1).Offset(20 * j)
Next
.Range("E:E").EntireColumn.Insert
.Range("C:D").EntireColumn.Insert
.Range("B:B").EntireColumn.Insert
.Range("M:Q").EntireColumn.Insert
End With
End Sub

bananas
06-12-2016, 12:46 PM
Wow! That was a quick answer, mdmackillop.
Your code works exactly as I asked for but unfortunately I missed to tell some vital information:
I must use "DEF*" in my old code but I can't see that in your code.
Also, almost every cell (except specified) in destination worksheet, Range (A1:AM500) is occupied with data or excel functions, so inserting EntireColumns or EntireRows will not work.
I hope you still can help me.
Thanks a ton.

mdmackillop
06-12-2016, 01:09 PM
I used DEF to look at xlPart rather than xlWhole.


Option Explicit


Sub CopyDynamic()
Dim ABC(), DEF()
Dim c As Range
Dim i As Long, j As Long, k As Long
Dim FA As String
Dim Source, Target

ReDim ABC(1000), DEF(1000)

With Sheets(1).Columns(1)
Set c = .Find("ABC", lookat:=xlWhole, after:=Cells(1, 1))
FA = c.Address
Do
ABC(i) = c.Offset(1).Address
i = i + 1
Set c = .FindNext(c)
Loop Until c Is Nothing Or c.Address = FA


i = 0
Set c = .Find("DEF*", lookat:=xlWhole, after:=Cells(1, 1))
FA = c.Address
Do
DEF(i) = c.Offset(-1).Address
i = i + 1
Set c = .FindNext(c)
Loop Until c Is Nothing Or c.Address = FA
End With

ReDim Preserve ABC(i - 1)
ReDim Preserve DEF(i - 1)

Source = Array(0, 1, 2, 3, 4, 8)
Target = Array(0, 2, 5, 6, 8, 17)

With Sheets(2)
For j = 0 To i - 1
Set c = Sheets(1).Range(ABC(j) & ":" & DEF(j))
For k = 0 To 5
c.Offset(, Source(k)).Copy .Cells(2, 1).Offset(20 * j, Target(k))
Next k
Next
End With
End Sub

bananas
06-13-2016, 03:58 AM
mdmackillop, You are a genius!!!
It works! I owe you!
Thanks a lot!!!