VBA Question: How to make this happen...

zendog1960

zendog1960

Active Member
Joined
Sep 27, 2003
Messages
459
Office Version
  1. 2019
Platform
  1. Windows
In the first table below I have a list of clients. Their ID Numbers are in Column A, their names in Column B, Column C holds a picture name, Column D is a formula to create a complete path to the image, Column E has a hyperlink to that image. Columns G & H is a table of each client and their ID numbers for use with vlookups and such. Now after the first table below I will explain what I am wanting to do....


Excel 2007
ABCDEFGH
112001Corina Stadler12001 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 01.jpg12001 - 01.jpg0-
212001Corina Stadler12001 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 02.jpg12001 - 02.jpg1xx - NoPhotoAvailable
312001Corina Stadler12001 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 03.jpg12001 - 03.jpg12001Corina Stadler
412002Stephanie Taggart12002 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 01.jpg12002 - 01.jpg12002Stephanie Taggart
512002Stephanie Taggart12002 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 02.jpg12002 - 02.jpg12003Trae Fowler
612003Trae Fowler12003 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12003 - 01.jpg12003 - 01.jpg12004Heather Perkins
712004Heather Perkins12004 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12004 - 01.jpg12004 - 01.jpg12005Raylene Irwin
812005Raylene Irwin12005 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12005 - 01.jpg12005 - 01.jpg
Sheet1
Cell Formulas
RangeFormula
D1=IF(C1<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C1,"")
D2=IF(C2<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C2,"")
D3=IF(C3<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C3,"")
D4=IF(C4<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C4,"")
D5=IF(C5<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C5,"")
D6=IF(C6<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C6,"")
D7=IF(C7<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C7,"")
D8=IF(C8<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C8,"")


What I want to do is copy the image hyperlinks into the corresponding row for that client. As you can see, Corina has 3 different pictures, Stephanie has 2 and the rest have only 1. This is just a sample from over hundreds of clients. How can I do this via VBA. I am having a difficult time wrapping my head around this.

Any and all help would be greatly appreciated!


Excel 2007
GHIJK
10-
21xx - NoPhotoAvailable
312001Corina Stadler12001 - 01.jpg12001 - 02.jpg12001 - 03.jpg
412002Stephanie Taggart12002 - 01.jpg12002 - 02.jpg
512003Trae Fowler12003 - 01.jpg
612004Heather Perkins12004 - 01.jpg
712005Raylene Irwin12005 - 01.jpg
Sheet1
Cell Formulas
RangeFormula
G10
G21
G312001
G412002
G512003
G612004
G712005
H1-
H2xx - NoPhotoAvailable
H3Corina Stadler
H4Stephanie Taggart
H5Trae Fowler
H6Heather Perkins
H7Raylene Irwin
I312001 - 01.jpg
I412002 - 01.jpg
I512003 - 01.jpg
I612004 - 01.jpg
I712005 - 01.jpg
J312001 - 02.jpg
J412002 - 02.jpg
K312001 - 03.jpg
 
Sort by date Sort by votes
zendog1960,

Thanks for the new workbook.

Sample raw data (not all 132 rows are shown for brevity:


Excel 2007
ABCDE
112001Corina Stadler12001 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 01.jpg12001 - 01.jpg
212001Corina Stadler12001 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 02.jpg12001 - 02.jpg
312001Corina Stadler12001 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 03.jpg12001 - 03.jpg
412002Stephanie Taggart12002 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 01.jpg12002 - 01.jpg
512002Stephanie Taggart12002 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 02.jpg12002 - 02.jpg
612003Trae Fowler12003 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12003 - 01.jpg12003 - 01.jpg
712004Heather Perkins12004 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12004 - 01.jpg12004 - 01.jpg
812005Raylene Irwin12005 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12005 - 01.jpg12005 - 01.jpg
912007Chantell Heupel12007 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12007 - 01.jpg12007 - 01.jpg
1012007Chantell Heupel12007 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12007 - 02.jpg12007 - 02.jpg
1112007Chantell Heupel12007 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12007 - 03.jpg12007 - 03.jpg
1212008Mathea Aspelund12008 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12008 - 01.jpg12008 - 01.jpg
1312008Mathea Aspelund12008 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12008 - 02.jpg12008 - 02.jpg
1412008Mathea Aspelund12008 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12008 - 03.jpg12008 - 03.jpg
1512013Blaze Angeline12013 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12013 - 01.jpg12013 - 01.jpg
1612014Josy Rudnick12014 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12014 - 01.jpg12014 - 01.jpg
1712018Amber Downing12018 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12018 - 01.jpg12018 - 01.jpg
1812019William Baker12019 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12019 - 01.jpg12019 - 01.jpg
1912019William Baker12019 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12019 - 02.jpg12019 - 02.jpg
2012019William Baker12019 - 03.JPGe:\01 - Bullethead Tattoo\02 - Tattoos\12019 - 03.JPG12019 - 03.JPG
2112021Josh Rodriguez12021 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12021 - 01.jpg12021 - 01.jpg
2212021Josh Rodriguez12021 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12021 - 02.jpg12021 - 02.jpg
2312021Josh Rodriguez12021 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12021 - 03.jpg12021 - 03.jpg
2412021Josh Rodriguez12021 - 04.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12021 - 04.jpg12021 - 04.jpg
2512022Tonya Ivanoff12022 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12022 - 01.jpg12022 - 01.jpg
2612022Tonya Ivanoff12022 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12022 - 02.jpg12022 - 02.jpg
TatPics
Cell Formulas
RangeFormula
D1=IF(C1<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C1,"")


After the new macro (not all 72 rows are shown for brevity):


Excel 2007
GHIJKLMNO
112001Corina Stadler12001 - 01.jpg12001 - 02.jpg12001 - 03.jpg
212002Stephanie Taggart12002 - 01.jpg12002 - 02.jpg
312003Trae Fowler12003 - 01.jpg
412004Heather Perkins12004 - 01.jpg
512005Raylene Irwin12005 - 01.jpg
612007Chantell Heupel12007 - 01.jpg12007 - 02.jpg12007 - 03.jpg
712008Mathea Aspelund12008 - 01.jpg12008 - 02.jpg12008 - 03.jpg
812013Blaze Angeline12013 - 01.jpg
912014Josy Rudnick12014 - 01.jpg
1012018Amber Downing12018 - 01.jpg
1112019William Baker12019 - 01.jpg12019 - 02.jpg12019 - 03.JPG
1212021Josh Rodriguez12021 - 01.jpg12021 - 02.jpg12021 - 03.jpg12021 - 04.jpg
1312022Tonya Ivanoff12022 - 01.jpg12022 - 02.jpg12022 - 03.jpg12022 - 04.jpg
1412023Katie Lauderdale12023 - 01.jpg
1512024Marquie Casteel12024 - 01.jpg12024 - 02.jpg12024 - 03.jpg
1612025Amanda Maybee12025 - 01.jpg12025 - 02.jpg
1712026David Van Horn12026 - 01.jpg12026 - 02.jpg12026 - 03.jpg
1812027Becky Stinson12027 - 01.jpg
1912029Ian Nasayao12029 - 01.jpg
2012030Terri Tidmore12030 - 01.jpg12030 - 02.jpg
2112031Kristina Fritz12031 - 01.jpg12031 - 02.jpg12031 - 03.jpg
2212032Tyler Ferrell12032 - 01.jpg
2312033Andrew Reeves12033 - 01.jpg
2412034Jennifer Van Horn12034 - 01.jpg
2512035Sara Griffin12035 - 01.jpg12035 - 02.jpg12035 - 03.jpg12035 - 03a.jpg12035 - 03b.jpg12035 - 03c.jpg12035 - 03d.jpg
TatPics




Code: 
Option Explicit
Sub ReorgDataV3()
' hiker95, 12/17/2013
' http://www.mrexcel.com/forum/excel-questions/745454-visual-basic-applications-question-how-make-happen.html
Dim lr As Long, nrg As Long, r As Long, nr As Long, n As Long, rr As Long, nc As Long
Sheets("TatPics").Activate
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  nrg = Range("G" & Rows.Count).End(xlUp).Offset(1).Row
  If nrg = 2 And Range("G1") = "" Then nrg = 1
  If n = 1 Then
    Range("G" & nrg).Resize(, 2).Value = Range("A" & r).Resize(, 2).Value
    Range("E" & r).Copy Range("I" & nrg)
  ElseIf n > 1 Then
    Range("G" & nrg).Resize(, 2).Value = Range("A" & r).Resize(, 2).Value
    nc = 8
    For rr = r To r + n - 1
      nc = nc + 1
      Cells(rr, "E").Copy Cells(nrg, nc)
    Next rr
  End If
  r = r + n - 1
Next r
Columns.AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV3 macro.


The new macro contains two additional lines of code:
Sheets("TatPics").Activate
Columns.AutoFit
 
Upvote 0

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
You must log in or register to reply here.

Similar threads

A
  • Solved
Extract data based on matching headers with sheets names across sheets
Replies
4
Views
313
Ali M
A
A
  • Solved
Track movement stock in listbox on userform by copy amounts from previous row to next row
Replies
8
Views
105
abdo meghari
A
A
  • Question Question
Create report by matching part of item and populate for each cell under item across sheets
Replies
2
Views
217
Ali M
A
A
  • Solved
AVERAGEIFS with 4 criteria
2
Replies
16
Views
761
Fluff
Fluff
V
  • Solved
Formula to calculate automatically progressive average
Replies
5
Views
505
etaf
etaf

Forum statistics

Threads
1,224,814
Messages
6,181,124
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top